VBS – time stamp: options demo

VBS will run in Windows as a stand alone script just like JS (JavaScript) and BATCH files.

'save as ANSI TXT file with extenstion ".vbs" 
'saving as UTF and Unicode will show "Error in Line 1"
nowis = Now
msgbox minuteStamp, vbOKOnly,"MinuteStamp"
msgbox timeStamp, vbOKOnly, "TimeStamp"
msgbox timestamphhmmss(nowis), vbOKOnly, "Time Stamp hh mm ss"

' ==== 'right' forces two digit values ===
Function minuteStamp() 
 minuteStamp = Year(Now) & "_" & _
 Right("0" & Month(Now),2) & "_" & _
 Right("0" & Day(Now),2) & "_" & _ 
 Right("0" & Hour(Now),2) & _
 Right("0" & Minute(Now),2) 
 '& _ Right("0" & Second(Now),2) 
End Function

' ============
Function timeStamp()
 timeStamp = Year(Now) & "_" & _
 Right("0" & Month(Now),2) & "_" & _
 Right("0" & Day(Now),2) & "_" & _ 
 Right("0" & Hour(Now),2) & _
 Right("0" & Minute(Now),2) & _
 Right("0" & Second(Now),2) 
End Function
' ======


Function timestamphhmmss(someTime)
 timestamphhmmss = FormatDateTime(someTime,vbshorttime) & ":" & right("0" & Second(someTime), 2)
End Function
 
'Constant Value Description from Microsoft® HELP
'vbGeneralDate 0 Display a date and/or time. If there is a date part, display it as a short date. If there is a time part, display it as a long time. If present, both parts are displayed.
' vbLongDate 1 Display a date using the long date format specified in your computer's regional settings.
' vbShortDate 2 Display a date using the short date format specified in your computer's regional settings.
' vbLongTime 3 Display a time using the time format specified in your computer's regional settings.
' vbShortTime 4 Display a time using the 24-hour format (hh:mm).
'_______________________________

 

Macro: datetimestamp()

Appends date/time stamp to current cell.

Sub datestamp()
Dim strWhatTime
 
 strWhatTime = Format(Now(), "mm-dd-yy hh:mm:ss ddd")
 If ActiveCell.Value = "" Then
 ActiveCell.Value = strWhatTime
 '& (tempp - Int(temp))
 'ActiveCell.Value = Format(Now(), "c") '& (tempp - Int(temp))
 Else
 ActiveCell.Value = ActiveCell.Value & " " & strWhatTime
 End If
 
End Sub
'ActiveCell.FormulaR1C1 = "11/1/2011"

AHK Macro: Show NumLock, Insert

Is your LAPTOP  keyboard MISSING the STATUS INDICATOR for Insert , CapsLock or NumLock keys?

*IF* your computer once had but LOST this feature, it will be EASIER for you to reinstall from your OEM's website or the installation disk that *may* have come with your computer.

Otherwise this will help!  Requires installing AHK.

; AHK script - a great PLAN B if your laptop is missing this feature AND not available from the OEM download page

~CapsLock:: ; Show CapsLock state on screen
 if GetKeyState("CapsLock", "T")
 Progress, B1 W200 H28 ZH0 FS11 WS900 Y700 CTFF0000, CAPS LOCK ON
 else
 Progress, B1 W200 H28 ZH0 FS11 WS900 Y700 CT0000FF, CAPS LOCK OFF
 SetTimer, OSD_OFF, -2000
 return

~NumLock:: ; Show NumLock state on screen
 if GetKeyState("NumLock", "T")
 Progress, B1 W200 H28 ZH0 FS11 WS900 Y700 CT00FF00, NUM LOCK ON
 else
 Progress, B1 W200 H28 ZH0 FS11 WS900 Y700 CTFF0000, NUM LOCK OFF
 SetTimer, OSD_OFF, -2000
 return

~Insert:: ; Show Insert state on screen
 if GetKeyState("Insert", "T")

 Progress, B1 W200 H28 ZH0 FS11 WS900 Y700 CTE60316, OVERWRITE MODE
else
 Progress, B1 W200 H28 ZH0 FS11 WS900 Y700 CT007800, INSERT MODE
 SetTimer, OSD_OFF, -2000
 return

OSD_OFF:
 Progress, off
 return

;https://autohotkey.com/board/topic/67080-display-capslock-state-helpful-for-vim/?hl=numlock+state#entry457616
 ; https://autohotkey.com/docs/KeyList.htm

Other AHK resources:

Install AutoHotKey for Windows
AHK Tutorial
Setup Notepad++ for AutoHotkey

 

 

Merge with Zero Data Loss

This macro is best called by assigning it to a short-cut key-sequence, e.g. "Ctrl-Shift-M"(erge).  Do this in the Macro Edit dialog by the Excel short-cut sequence Alt-T-M-M (See SWF video - will run in most browsers: IE, Chrome, Firefox). It calls "nibble" which has it's own Post, but is also included below.

Sub mergeselection()
 Dim strTemp As String
 Dim youAreHere As Object
 Dim cc, k As Integer
 
 Set youAreHere = ActiveCell
' MsgBox ActiveCell.Address
' MsgBox Selection.Rows.Count
 
 
 For Each cc In Selection.Cells
 strTemp = strTemp & vbCrLf & cc.Value
 'strTemp = strTemp & vbCrLf & k + 1 & " " & cc.Value
 'k = k + 1
 Next cc
 With Selection  'With Selection is left over from macro recording
 .HorizontalAlignment = xlCenter
 .VerticalAlignment = xlBottom
 .WrapText = False
 .Orientation = 0
 .AddIndent = False
 .IndentLevel = 0
 .ShrinkToFit = False
 .ReadingOrder = xlContext
 ' .MergeCells = False
 End With
 Application.DisplayAlerts = False
 Selection.Merge
 Application.DisplayAlerts = True
 strTemp = nibble(strTemp) '& vbCrLf
 
 With youAreHere
 youAreHere.Value = strTemp
 youAreHere.HorizontalAlignment = xlLeft
 youAreHere.VerticalAlignment = xlTop
 youAreHere.Activate
 End With
 
End Sub

' ===========================
Private Function nibble(somestring)
 'Dim islf
 If Len(somestring) >= 1 Then
 While (Asc(Left(somestring, 1)) <= 13) 'this will eat vbTab chr(9) !!!
 ' islf = asc(right(somestring,1))
 somestring = Right(somestring, Len(somestring) - 1)
 Wend
 End If
 nibble = somestring
End Function

 

Batch: Clean Windows Desktop

Runs from any location - moves designated files into a new folder on the desktop  named with  today's date

@echo off
rem DESKCLEAN.BAT MAKES DAILY FOLDER FOR WORKING FILES - UNcomment DEBUGFLAG to troubleshoot / pause
:set debugflag=ANYTHING
:set PAUSEFLAG=ANYTHING
IF NOT "%DEBUGFLAG%"=="" ECHO ON
setlocal
pushd %userprofile%\Desktop
set filestring=*.pdf;*.txt;*.log;*.xls*;*.sql;*.bak;*.java;*.class;*.jp*;*.gif;*.png;*.bku;*.bkk;*.bmp;*.htm*;*.php;*.cs;*.pl;*.py;*.rb;*.doc*;*.ppt*

 REM set newdir=_hold_%timestamp% - RATHER THAN HUNT FOR THIS LINE 
rem DEEPER, ASSIGN PREFIX / FOLDER NAME NEXT LINE

 SET DIRPREFIX=

 rem has Day of Week from below "rem set xdate=%xdate:~4%"

rem makedir with timestamp - the source for the odd string manipulators below is cmd's "help for" and "help if"

: below - remove in sequence, colon, period, space, slash (replace
 rem with underscore) then last two remove trailing 1/100ths of second and leading day of week
:xtime not used

set xtime=%time::=%
set xtime=%xtime:.=_%
set xtime=%xtime: =0%
set xtime=%xtime:~0,-3%
set xdate=%date: =_%
set xdate=%xdate:/=_%
rem set xdate=%xdate:~4%
set timestamp=%xdate%

 rem set newdir=_%timestamp%
set newdir=%DIRPREFIX%%timestamp%
 rem set newdir=_%timestamp%
 rem remark out above line if you want day of week included at front
rem set timestamp=%xdate%_%xtime% rem this includes timestamp seconds, making unique folder - OMIT to have only one folder per day

for %%x in (%filestring%) do if exist "%%x" if not exist "%newdir%" md "%newdir%"
for %%x in (%filestring%) do if exist "%%x" move "%%x" %newdir%


rem for %%x in (*.tif;*.jpg;*.jpg;*.gif;*.pdf;*.txt;*.log;*.xls*;*.sql;*.bak;*.bku)
 if exist "%%x" if not exist %newdir% md %newdir%
rem for %%x in (*.tif;*.jpg;*.jpg;*.gif;*.pdf;*.txt;*.log;*.xls*;*.sql;*.bak;*.bku)
 if exist "%%x" move "%%x" %newdir%
IF "%DEBUGFLAG%"=="" GOTO END

pause
:END
popd
: UNcomment any below to pause and see variables at work, also (un)comment top line with @echo
:set n
:SET D
:set x
:set f
:set t 
IF NOT "%PAUSEFLAG%"=="" PAUSE

endlocal

 

 

Excel to the Horse Races

Excel to the Horse Races
A working demonstration of unit conversion between old and new methods.

In this case COMPARE same Horse in different TRACKS and CONDITIONS:
furlongs, meters, feet, yards!  (Screenshots and download links below).

Conversion Demonstration - furlongs, meters, yards, miles

BEST PRACTICE ALERT: TEST your default security
and SCAN BEFORE downloading ANY product with MACROs.
This can be handled by most modern anti-virus software (I use
Webroot) *AND* by setting your Excel, or Word Options | Trust settings to highest security.

Consumer bears full responsibility to scan for unexpected code errors, malware or viruses.

http://excel-on-demand/wp-content/uploads/2017/01/equus044b1.xlsm (optional Active-X button and macro in first sheet to simplify default setting.)

http://excel-on-demand/wp-content/uploads/2017/01/equus044b2.xlsx (no local macro: ActiveX buttons only work in local tab: use a "form button" element to if you want to call a button handler from the local macro template in folder "XLStart")

Powerpoint Update all Fonts

Update all Slides' single Font - to improve readability via video projector

REVERTs multiple fonts to the SINGLE font (Arial) chosen on line 3

Sub FarEastFontsToArial()
 Dim oSh As Shape, oSl As Slide, strFont as String
strFont = "Arial" 'or Calibri or your choice

For Each oSl In ActivePresentation.Slides
 For Each oSh In oSl.Shapes
 If oSh.HasTextFrame Then
 oSh.TextFrame.TextRange.Font.NameFarEast = strFont
 End If
 Next
 Next

For Each oSh In ActivePresentation.SlideMaster.Shapes
 If oSh.HasTextFrame Then
 oSh.TextFrame.TextRange.Font.NameFarEast = strFont
 End If
 Next

If ActivePresentation.HasTitleMaster Then
 For Each oSh In ActivePresentation.TitleMaster.Shapes
 If oSh.HasTextFrame Then
 oSh.TextFrame.TextRange.Font.NameFarEast = strFont 
End If 
Next Osh
End If 
End Sub

'Must turn on macros in File | Options

Powerpoint breaks Asian Wordwrap

Powerpoint breaks Asian Wordwrap

'this macro solves  "orphan letters" being seperated from words by converting each slide's "LineBreakLevel" to  strict

 

Sub strict_asian_punct()

' exampleThis example sets line break control to use level one kinsoku characters. There are three levels designated by PowerPoint HELP
'ppFarEastLineBreakLevelCustom
'ppFarEastLineBreakLevelNormal
'ppFarEastLineBreakLevelStrict


 For Each oSl In ActivePresentation.Slides
 ActivePresentation.FarEastLineBreakLevel = ppFarEastLineBreakLevelStrict
 Next oSl

End Sub

Excel Macro Autonumber NonBlanks

Sub NumbernonBlankTestLines()
' user must manually highlight range in Column A
Dim msgs, qy, rep
Dim testcount, r, c As Integer,
Dim startHere As Range, rngSelected As Range
Dim markblank, enforcesinglerowblank As Boolean
enforcesinglerowblank = False

' MsgBox "last cell is " & findlastusedcell()
' use if we add feature to insert column A and auto-select range

testcount = 0

Set startHere = ActiveCell
Set rngSelected = Selection

If TypeName(Selection) = "Range" Then
If Selection.Areas.Count = 1 Then
' MsgBox "selected rows is " & rngSelected.Rows.Count & vbCrLf & "columnn is " & ActiveCell.Column

If rngSelected.Rows.Count < 2 Or ActiveCell.Column <> 1 Then GoTo oops

' magic starts here
'Selection.Name = "eraseme"
markblank = False
'MsgBox rngSelected.Rows.Count

If WorksheetFunction.CountA(rngSelected) > 1 Then
qy = MsgBox("OVERWRITE existing DATA?", vbOKCancel, "WARNING!")
If qy = vbCancel Then
Exit Sub
Else
rngSelected.ClearContents
End If
'WorksheetFunction.CountA(rngSelected)
End If
For r = 1 To rngSelected.Rows.Count

rngSelected(r).Activate

If r = 1 Then
If rngSelected(r).Offset(0, 1) = "" Then
MsgBox rngSelected(r).Offset(0, 1).Value
GoTo oops
End If
End If

'case not blank
If rngSelected(r).Offset(0, 1) > "" Then
If enforcesinglerowblank And markblank Then
GoTo doublelineerror
ElseIf Not markblank Or Not enforcesinglerowblank Then
markblank = Not markblank
rngSelected(r).Value = testcount + 1
' markblank = False Else markblank = True
testcount = testcount + 1
End If
'case blank
ElseIf rngSelected(r).Offset(0, 1) = "" Then
If enforcesinglerowblank And Not markblank Then
GoTo doublelineerror
ElseIf markblank Then
markblank = Not markblank
End If
Else: MsgBox
"Unknown", vbCritical, "Error!"

End If

Next r
' GoTo A1
MsgBox "Numbered " & testcount & " rows"
'measure column B begin and end
'make temporary range from A2: to match B begin to B end

'tbd select column A
'if selection < 2 rows warn and exit
'for each row in A, test adjacent cell B has value - number A, set flag notblank
'if flag notblank then next row should be blank, else warn andexit else skip to next
'if flag notblank, then next row should NOT be blank, else warn and exit, else number A
Else
MsgBox
"Please select only one area.", vbInformation
End If
End If
Exit Sub

doublelineerror:
MsgBox "Only one row per test, MUST be separated by exactly one blank row: see Test# " & testcount, vbCritical, "Halted / Config Error"

Exit Sub

oops:
MsgBox "HALTED: must select multiple continuous rows within column A, alongside alternating data in column B" & vbCrLf _
& "and first selected row is NOT blank", vbCritical, "SELECTION ERROR"

End Sub