After weeks I finally think I have a working SendKeys.
- It does't change NumLock state
- It doesn't interfere with already pressed modifying keys
- Checks not wanted manually pressed modifying keys
- Compatible with build-in SendKeys, but with more features
- Pauses in exact milliseconds, even when going over 23:59:59
- Able to send the characters + ^ % ~
- Works on Windows 7, Excel 64-bit
Please test and report problems. Thank you.
- It does't change NumLock state
- It doesn't interfere with already pressed modifying keys
- Checks not wanted manually pressed modifying keys
- Compatible with build-in SendKeys, but with more features
- Pauses in exact milliseconds, even when going over 23:59:59
- Able to send the characters + ^ % ~
- Works on Windows 7, Excel 64-bit
Please test and report problems. Thank you.
Code:
Private Enum enumKBE [COLOR=#008000]'''Sub Keybd_event[/COLOR]
KBE_KeyDown = 0
KBE_KeyUp = 2
KBE_ExtKeyDown = 1
KBE_ExtKeyUp = 3
End Enum
Private Type SYSTEMTIME[COLOR=#008000]'''Sub GetLocalTim[/COLOR]e
wYear As Integer
wMonth As Integer
wDayOfWeek As Integer
wDay As Integer
wHour As Integer
wMinute As Integer
wSecond As Integer
wMilliseconds As Integer
End Type
Private Enum enumMAPVK [COLOR=#008000]'''Function MapVirtualKey Lib "user32" [/COLOR]
MAPVK_VK_TO_VSC = 0
MAPVK_VSC_TO_VK = 1
MAPVK_VK_TO_CHAR = 2
MAPVK_VSC_TO_VK_EX = 3
End Enum
#If VBA7 Or Win64 Then
Private Declare PtrSafe Sub Keybd_event Lib "user32" Alias "keybd_event" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlagsv As enumKBE, ByVal dwExtraInfo As LongPtr)
[COLOR=#008000] '''Synthesizes a keystroke. The system can use such a synthesized keystroke to generate a WM_KEYUP or WM_KEYDOWN message.[/COLOR]
Private Declare PtrSafe Function OemKeyScan Lib "user32" (ByVal wOemChar As Long) As Long
[COLOR=#008000] '''Provides information that allows a program to send OEM text to another program by simulating keyboard input.[/COLOR]
Private Declare PtrSafe Function CharToOem Lib "user32" Alias "CharToOemA" (ByVal lpszSrc As String, ByVal lpszDst As String) As Long
[COLOR=#008000] '''Translates a string into the OEM-defined character set of 2[/COLOR]
Private Declare PtrSafe Function VkKeyScan Lib "user32" Alias "VkKeyScanA" (ByVal cChar As Byte) As Integer
[COLOR=#008000] '''Translates a character to the corresponding virtual-key code and shift state for the current keyboard.[/COLOR]
Private Declare PtrSafe Function GetKeyState Lib "user32" (ByVal nVirtKey As Integer) As Integer
[COLOR=#008000] '''Retrieves the status of the specified virtual key whether the key is up, down, or toggled (alternating on/off each time the key is pressed).[/COLOR]
Private Declare PtrSafe Function MapVirtualKey Lib "user32" Alias "MapVirtualKeyA" (ByVal uCode As Long, ByVal uMapType As enumMAPVK) As Long
[COLOR=#008000] '''Translates (maps) a virtual-key code into a scan code or character value, or translates a scan code into a virtual-key code.[/COLOR]
Private Declare PtrSafe Sub GetLocalTime Lib "kernel32" (lpSystemTime As SYSTEMTIME)
[COLOR=#008000] '''Retrieves the current local date and time with milliseconds.[/COLOR]
#Else
[COLOR=#ffa07a] Private Declare Sub Keybd_event Lib "user32" Alias "keybd_event" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlagsv As enumKBE, ByVal dwExtraInfo As Long)
Private Declare Function OemKeyScan Lib "user32" (ByVal wOemChar As Long) As Long
Private Declare Function CharToOem Lib "user32" Alias "CharToOemA" (ByVal lpszSrc As String, ByVal lpszDst As String) As Long
Private Declare Function VkKeyScan Lib "user32" Alias "VkKeyScanA" (ByVal cChar As Byte) As Integer
Private Declare Function GetKeyState Lib "user32" (ByVal nVirtKey As Integer) As Integer
Private Declare Function MapVirtualKey Lib "user32" Alias "MapVirtualKeyA" (ByVal uCode As Long, ByVal uMapType As enumMAPVK) As Long
Private Declare Sub GetLocalTime Lib "kernel32" (lpSystemTime As SYSTEMTIME)[/COLOR]
#End If
Private Sub test_fSendKeys()
[COLOR=#008000]' fTimer 1000 '''enable pressing Alt after starting this sub[/COLOR]
[COLOR=#008000]' fSendKeys "%({tab}{tab})" '''switch to 3th application[/COLOR]
[COLOR=#008000]' fSendKeys "{win}e" '''open new windows-explorer[/COLOR]
[COLOR=#008000]' fSendKeys "{ctrl}(g{end}){F7}" '''switch to Immediate window, set cursor to last line and come back to vba-code[/COLOR]
fSendKeys "^(g{home}+{end}){del}"[COLOR=#008000] '''clear Immediate window[/COLOR]
End Sub
Function fSendKeys(ByVal keyStrokes As String, Optional waitMilliseconds As Integer) [COLOR=#008000]'''16/06/2013, michel(dot)be(a)gmail....[/COLOR]
[COLOR=#008000]'''Simulates key-strokes without changing the already pressed modifying keys[/COLOR]
[COLOR=#008000]'''Note: The VBA build-in SendKeys is not reliable, like it messes up the Num-, Shift- and Scroll-Lock state![/COLOR]
[COLOR=#008000]'''Differences with the VBA build in SendKeys. http://msdn.microsoft.com/en-us/library/office/ff821075.aspx[/COLOR]
[COLOR=#008000]''' Pauses using "{milliSeconds}", max 30000(=30sec), min 2 characters as in {01} (=1 millisecond)[/COLOR]
[COLOR=#008000]''' To send a special or any character as the character itself, place in in {}: {^} {+} {{} {)} {~} ...[/COLOR]
[COLOR=#008000]''' {Ctrl} or ^, {Alt} or %, {Shift} or +, {Win}, {Apps}, {CtrlR}, {ShiftR},... will hold down that modifying key while pressing next key[/COLOR]
[COLOR=#008000]''' Use () to know the end using the last group of modifying keys.[/COLOR]
[COLOR=#008000]''' {NumLock}, {ShiftLock}, {ScrollLock}, {Insert} will swap state, so check state first with CBool(GetKeyState(vbKeyNumlock) And 1)[/COLOR]
[COLOR=#008000]'''ATTENTION: Don't debug this function using the keys Shift, Ctrl and Alt, but use the debug-bar-buttons !!!![/COLOR]
[COLOR=#008000]''' If you get stuck, press every L & R modifying key ones.[/COLOR]
[COLOR=#008000]'''Thanks to Bryan Wolf, Chip Pearson and many others on the net for info ;-)[/COLOR]
[COLOR=#008000]'''Examples: "^(g{home}+{end}){del}" '''= Ctrl+G Ctrl+Home Ctrl+Shift+End Del = Immediate window cleared[/COLOR]
Dim keyCode As Integer, scanCode As Long, v As Variant, extKey As Byte
Dim str2Char As String * 2, nextKey As Variant, specialKey As String, modKeys As String, startTime As Variant
If waitMilliseconds > 0 Then keyStrokes = keyStrokes & "{0" & waitMilliseconds & "}"
Do
keyCode = -1
scanCode = -1
specialKey = ""
nextKey = Left(keyStrokes, 1) [COLOR=#008000]'''take first character[/COLOR]
keyStrokes = Mid(keyStrokes, 2) [COLOR=#008000]'''delete first character from list to process[/COLOR]
If nextKey = "{" Then[COLOR=#008000] '''handle everything in between "{" and "}"[/COLOR]
nextKey = Split(keyStrokes, "}")(0) [COLOR=#008000]'''grab key-name till next "}" or till end of string!!![/COLOR]
If Left(keyStrokes, 2) = "}}" Then nextKey = "}"[COLOR=#008000] '''it's "}" instead of "", because it was "{}}" not "{}"[/COLOR]
keyStrokes = Mid(keyStrokes, Len(nextKey) + 2)[COLOR=#008000] '''delete the key + "}" from the list to process[/COLOR]
If Len(nextKey) > 1 Then specialKey = nextKey [COLOR=#008000]'''more then 1 character = special key-name[/COLOR]
ElseIf nextKey = "(" And Left(keyStrokes, 1) = ")" Then[COLOR=#008000] ''' found "()", go and send "" with present modKeys[/COLOR]
nextKey = ""
keyStrokes = Mid(keyStrokes, Len(nextKey) + 2) [COLOR=#008000]'''delete ")" from the list to process[/COLOR]
ElseIf InStr("+^%~()", nextKey) Then
specialKey = nextKey
End If
Select Case UCase(specialKey) [COLOR=#008000]'''http://msdn.microsoft.com/en-us/library/windows/desktop/dd375731.aspx[/COLOR]
Case "" [COLOR=#008000] '''send the actual ascII key, even if it's "" or one of these +^%~(){} as actual ascII key[/COLOR]
CharToOem nextKey, str2Char [COLOR=#008000]'''Fill str2Char with the character translation. str2Char need to as string*2 ![/COLOR]
scanCode = OemKeyScan(Asc(str2Char)) [COLOR=#008000] '''Maps OemASCII*2 codes into the OEM scancodes and shiftstates.[/COLOR]
If nextKey <> "" Then
keyCode = VkKeyScan(Asc(nextKey))[COLOR=#008000] '''Translates character to virtual keycode and modifying-key-state.[/COLOR]
If (keyCode And &H100) Then modKeys = modKeys & ",016"[COLOR=#008000] '''Shift needs to be down for this character[/COLOR]
If (keyCode And &H200) Then modKeys = modKeys & ",017"[COLOR=#008000] ''' Ctrl needs to be down for this character[/COLOR]
If (keyCode And &H400) Then modKeys = modKeys & ",018"[COLOR=#008000] ''' Alt needs to be down for this character[/COLOR]
End If
Case "(": modKeys = modKeys & " "[COLOR=#008000] '''use a space to mark the next group between brackets[/COLOR]
Case ")": modKeys = Left(modKeys, InStrRev(RTrim(modKeys), " ")) [COLOR=#008000]'''delete last group of modifiers[/COLOR]
Case "SHIFT", "+": modKeys = modKeys & ",016"
Case "LSHIFT", "SHIFTL": modKeys = modKeys & ",160"
Case "RSHIFT", "SHIFTR": modKeys = modKeys & ",161"
Case "CONTROL", "CTRL", "^": modKeys = modKeys & ",017"
Case "LCONTROL", "CONTROLL", "LCTRL", "CTRLL": modKeys = modKeys & ",162"
Case "RCONTROL", "CONTROLR", "RCTRL", "CTRLR": modKeys = modKeys & ",163"[COLOR=#008000] '''=ext.key[/COLOR]
Case "MENU", "ALT", "%": modKeys = modKeys & ",018"
Case "LMENU", "MENUL", "LALT", "ALTL": modKeys = modKeys & ",164"
Case "RMENU", "MENUR", "RALT", "ALTR": modKeys = modKeys & ",165"[COLOR=#008000] '''=ext.key[/COLOR]
Case "LWIN", "WINL": modKeys = modKeys & ",091" [COLOR=#008000]'''=ext.key[/COLOR]
Case "RWIN", "WINR": modKeys = modKeys & ",092" [COLOR=#008000]'''=ext.key[/COLOR]
Case "APPS": modKeys = modKeys & ",093" [COLOR=#008000]'''=ext.key, no L/R version !!![/COLOR]
Case "WIN": modKeys = modKeys & ",094" [COLOR=#008000]'''=reserved key!!![/COLOR]
[COLOR=#008000] '''lock-keys[/COLOR]
Case "PAUSE": keyCode = vbKeyPause [COLOR=#008000] '''19[/COLOR]
Case "CAPSLOCK", "SHIFTLOCK", "CAPS": keyCode = vbKeyCapital[COLOR=#008000] '''20[/COLOR]
Case "INSERT", "INS": keyCode = vbKeyInsert [COLOR=#008000] '''45[/COLOR]
Case "NUMLOCK": keyCode = vbKeyNumlock[COLOR=#008000] '''144[/COLOR]
Case "SCROLLLOCK", "SCROLL": keyCode = &H91 [COLOR=#008000] '''145[/COLOR]
[COLOR=#008000] '''[/COLOR]
Case "BREAK", "CANCEL": keyCode = vbKeyCancel [COLOR=#008000]'''3[/COLOR]
Case "BACKSPACE", "BACK", "BS": keyCode = vbKeyBack [COLOR=#008000]'''8[/COLOR]
Case "TAB": keyCode = vbKeyTab [COLOR=#008000] '''9[/COLOR]
Case "CLEAR": keyCode = vbKeyClear [COLOR=#008000]'''12[/COLOR]
Case "RETURN", "~": keyCode = vbKeyReturn [COLOR=#008000]'''13[/COLOR]
Case "ESC", "ESCAPE": keyCode = vbKeyEscape [COLOR=#008000]'''27[/COLOR]
Case "SPACE": keyCode = vbKeySpace [COLOR=#008000] '''32[/COLOR]
Case "SELECT": keyCode = vbKeySelect [COLOR=#008000] '''41[/COLOR]
Case "PRINT": keyCode = vbKeyPrint [COLOR=#008000] '''42[/COLOR]
Case "EXECUTE": keyCode = vbKeyExecute [COLOR=#008000] '''43[/COLOR]
Case "SNAPSHOT", "PRTSC", "PRINTSCREEN": keyCode = vbKeySnapshot [COLOR=#008000]'''44[/COLOR]
Case "DELETE", "DEL": keyCode = vbKeyDelete [COLOR=#008000] '''46[/COLOR]
Case "HELP": keyCode = vbKeyHelp [COLOR=#008000] '''47[/COLOR]
[COLOR=#008000] '''cursor[/COLOR]
Case "PAGEUP", "PGUP", "PRIOR": keyCode = vbKeyPageDown [COLOR=#008000]'''33[/COLOR]
Case "PAGEDOWN", "PGDN", "NEXT": keyCode = vbKeyPageUp [COLOR=#008000]'''34[/COLOR]
Case "END": keyCode = vbKeyEnd [COLOR=#008000]'''35[/COLOR]
Case "HOME": keyCode = vbKeyHome [COLOR=#008000] '''36[/COLOR]
Case "LEFT": keyCode = vbKeyLeft [COLOR=#008000] '''37[/COLOR]
Case "UP": keyCode = vbKeyUp [COLOR=#008000] '''38[/COLOR]
Case "RIGHT": keyCode = vbKeyRight [COLOR=#008000] '''39[/COLOR]
Case "DOWN": keyCode = vbKeyDown [COLOR=#008000]'''40[/COLOR]
[COLOR=#008000] '''numberic pad[/COLOR]
Case "ENTER": keyCode = &H1C [COLOR=#008000]'''28[/COLOR]
Case "NUMPAD0": keyCode = vbKeyNumpad0 [COLOR=#008000] '''96[/COLOR]
Case "NUMPAD1": keyCode = vbKeyNumpad1 [COLOR=#008000]'''97[/COLOR]
Case "NUMPAD2": keyCode = vbKeyNumpad2 [COLOR=#008000]'''98[/COLOR]
Case "NUMPAD3": keyCode = vbKeyNumpad3 [COLOR=#008000] '''99[/COLOR]
Case "NUMPAD4": keyCode = vbKeyNumpad4 [COLOR=#008000]'''100[/COLOR]
Case "NUMPAD5": keyCode = vbKeyNumpad5 [COLOR=#008000]'''101[/COLOR]
Case "NUMPAD6": keyCode = vbKeyNumpad6 [COLOR=#008000]'''102[/COLOR]
Case "NUMPAD7": keyCode = vbKeyNumpad7 [COLOR=#008000]'''103[/COLOR]
Case "NUMPAD8": keyCode = vbKeyNumpad8 [COLOR=#008000]'''104[/COLOR]
Case "NUMPAD9": keyCode = vbKeyNumpad9 [COLOR=#008000]'''105[/COLOR]
Case "MULTIPLY": keyCode = vbKeyMultiply[COLOR=#008000] '''106[/COLOR]
Case "ADD": keyCode = vbKeyAdd [COLOR=#008000] '''107[/COLOR]
Case "SEPARATOR": keyCode = vbKeySeparator [COLOR=#008000]''108[/COLOR]
Case "SUBTRACT": keyCode = vbKeySubtract [COLOR=#008000]'''109[/COLOR]
Case "DECIMAL": keyCode = vbKeyDecimal [COLOR=#008000] '''110[/COLOR]
Case "DIVIDE": keyCode = vbKeyDivide [COLOR=#008000] '''111[/COLOR]
'''function
Case "F1": keyCode = vbKeyF1 [COLOR=#008000] '''112[/COLOR]
Case "F2": keyCode = vbKeyF2 [COLOR=#008000] '''113[/COLOR]
Case "F3": keyCode = vbKeyF3 [COLOR=#008000] '''114[/COLOR]
Case "F4": keyCode = vbKeyF4 [COLOR=#008000] '''115[/COLOR]
Case "F5": keyCode = vbKeyF5 [COLOR=#008000] '''116[/COLOR]
Case "F6": keyCode = vbKeyF6 [COLOR=#008000]'''117[/COLOR]
Case "F7": keyCode = vbKeyF7 [COLOR=#008000]'''118[/COLOR]
Case "F8": keyCode = vbKeyF8 [COLOR=#008000]'''119[/COLOR]
Case "F9": keyCode = vbKeyF9 [COLOR=#008000] '''120[/COLOR]
Case "F10": keyCode = vbKeyF10 [COLOR=#008000]'''121[/COLOR]
Case "F11": keyCode = vbKeyF11 [COLOR=#008000] '''122[/COLOR]
Case "F12": keyCode = vbKeyF12 [COLOR=#008000] '''123[/COLOR]
Case "F13": keyCode = vbKeyF13 [COLOR=#008000]'''124[/COLOR]
Case "F14": keyCode = vbKeyF14 [COLOR=#008000]'''125[/COLOR]
Case "F15": keyCode = vbKeyF15 [COLOR=#008000]'''126[/COLOR]
Case "F16": keyCode = vbKeyF16 [COLOR=#008000] '''127[/COLOR]
'''mouse button
Case "LBUTTON": keyCode = vbKeyLButton [COLOR=#008000]'''1[/COLOR]
Case "RBUTTON": keyCode = vbKeyRButton [COLOR=#008000] '''2[/COLOR]
Case "MBUTTON": keyCode = vbKeyMButton [COLOR=#008000]'''4[/COLOR]
Case "XBUTTON1": keyCode = &H5 '''5
Case "XBUTTON2": keyCode = &H6 [COLOR=#008000]'''6[/COLOR]
Case 1 To 30000: DoEvents
fTimer (Val(nextKey) / 1000) [COLOR=#008000]'''milliseconds to pause (max 30sec)[/COLOR]
Case Else: If MsgBox("Error in string of Key-Strokes to send!", vbExclamation + vbOKCancel _
, "Function fSendkeys()") = vbCancel Then Stop
End Select
If keyCode > -1 Or specialKey = "" Or (keyStrokes = "" And modKeys <> "") Then[COLOR=#008000] '''send keystroke[/COLOR]
[COLOR=#008000] '''Change modifying keys to the Left- or Right-equivalent, what ever is not already pressed down.[/COLOR]
[COLOR=#008000] '''Because otherwise the manually pressed key could rise or stays down as this function ends.[/COLOR]
[COLOR=#008000] '''Just in case the already pressed modifying key is released while running this function.[/COLOR]
DoEvents[COLOR=#008000] '''NEEDED FOR BUG: To be shure that a manual pressed modifying key after starting VBA-code can be read correctly[/COLOR]
If CBool(GetKeyState(161) And -128) Then [COLOR=#008000] '''R-Shift already (manually) down...[/COLOR]
modKeys = Replace(modKeys, "016", "160") [COLOR=#008000] '''...replace all Shift with L-Shift[/COLOR]
Else
modKeys = Replace(modKeys, "016", "161") [COLOR=#008000] '''replace all Shift with R-Shift[/COLOR]
End If
If CBool(GetKeyState(163) And -128) Then [COLOR=#008000] '''R-Ctrl already (manually) down...[/COLOR]
modKeys = Replace(modKeys, "017", "162") [COLOR=#008000]'''...replace all Ctrl with L-Ctrl[/COLOR]
Else
modKeys = Replace(modKeys, "017", "163") [COLOR=#008000] '''replace all Ctrl with R-Ctrl[/COLOR]
End If
If CBool(GetKeyState(165) And -128) Then [COLOR=#008000] '''R-Alt already (manually) down...[/COLOR]
modKeys = Replace(modKeys, "018", "164") [COLOR=#008000] '''...replace all Alt with L-Alt[/COLOR]
Else
modKeys = Replace(modKeys, "018", "165") [COLOR=#008000] '''replace all Alt with R-Alt[/COLOR]
End If
If CBool(GetKeyState(92) And -128) Then [COLOR=#008000] '''R-Win already (manually) down...[/COLOR]
modKeys = Replace(modKeys, "094", "091") [COLOR=#008000]'''...replace all Win with L-Win[/COLOR]
Else
modKeys = Replace(modKeys, "094", "092") [COLOR=#008000]'''replace all Win with R-Win[/COLOR]
End If
[COLOR=#008000] '''Check, wait and pop-up-message until not needed modifying keys are not manually pressed anymore.[/COLOR]
startTime = Now()[COLOR=#008000] '''get start time waiting[/COLOR]
Do
If InStr(modKeys, 160) Or InStr(modKeys, 161) Or CBool(GetKeyState(16) And -128) = 0 Then [COLOR=#008000]'''Shift needed or not pressed[/COLOR]
If InStr(modKeys, 162) Or InStr(modKeys, 163) Or CBool(GetKeyState(17) And -128) = 0 Then [COLOR=#008000]'''Ctrl needed or not pressed[/COLOR]
If InStr(modKeys, 164) Or InStr(modKeys, 165) Or CBool(GetKeyState(18) And -128) = 0 Then [COLOR=#008000]'''Alt needed or not pressed[/COLOR]
If InStr(modKeys, 91) Or InStr(modKeys, 92) _
Or (CBool(GetKeyState(91) And -128) = 0 And CBool(GetKeyState(92) And -128) = 0) Then [COLOR=#008000]'''Win needed or not pressed[/COLOR]
Exit Do
End If
End If
End If
End If
If Now() > startTime + TimeValue("00:00:02") Then [COLOR=#008000]'''to long waiting on key-release[/COLOR]
If MsgBox("Please release all mouse and keyboard buttons." _
, vbOKCancel, "Function fSendKeys()") = vbCancel Then Exit Function
startTime = Now() [COLOR=#008000]'''get start time waiting[/COLOR]
End If
DoEvents
Loop
[COLOR=#008000] '''Press all modifying keys, Shift, Ctrl and Alt when needed[/COLOR]
For Each nextKey In Split(Mid(modKeys, 2), ",")
If CBool(GetKeyState(nextKey) And -128) Then[COLOR=#008000] '''modifying key already down[/COLOR]
modKeys = Replace(modKeys, "," & nextKey, "") [COLOR=#008000]'''remove that key to not rise automaticly at the end[/COLOR]
Else [COLOR=#008000]'''if not already pressed down push modifying key down[/COLOR]
[COLOR=#008000] '''extended keys: AltR,CtrlR,WinL,WinR,App[/COLOR]
extKey = -(InStr(" 165 163 091 092 093 ", nextKey) > 0)
If nextKey = 165 And CBool(GetKeyState(162) And -128) = False Then[COLOR=#008000] '''if AltR while and CtrlL is up[/COLOR]
[COLOR=#008000] '''NEEDED FOR BUG: When pressing AltR, the CtrlL also go's down on some PC's (=AltGr)[/COLOR]
[COLOR=#008000] '''note: MapVirtualKey(nextKey, 0) not needed, works also with 0 for modifying keys[/COLOR]
Keybd_event nextKey, 0, KBE_KeyDown + extKey, 0 [COLOR=#008000]'''press AltR (AltGr)[/COLOR]
Keybd_event 162, 0, KBE_KeyUp, 0[COLOR=#008000] '''release CtrlL[/COLOR]
Else
Keybd_event nextKey, 0, KBE_KeyDown + extKey, 0
End If
End If
Next
[COLOR=#008000] '''Press the key while modifying keys are down[/COLOR]
If keyCode <> -1 Then
If scanCode = -1 Then[COLOR=#008000] '''not a character-key but a named key, like {End}...[/COLOR]
scanCode = MapVirtualKey(keyCode, 0)
[COLOR=#008000] '''extended keys:NUMenter PUP PDN END HOME L UP R DWN PSC INS DEL CTRLR ALTR NUMLCK NUM/[/COLOR]
extKey = -(InStr(" 28 33 34 35 36 37 38 39 40 44 45 46 163 165 144 111 ", " " & keyCode & " ") > 0)
Else
extKey = 0
End If
Keybd_event (keyCode And &HFF), (scanCode And &HFF), KBE_KeyDown + extKey, 0 [COLOR=#008000]'''KBE_KeyDown=0 +1(if extended key)[/COLOR]
Keybd_event (keyCode And &HFF), (scanCode And &HFF), KBE_KeyUp + extKey, 0 [COLOR=#008000]'''KBE_KeyUp = 2 +1(if extended key)[/COLOR]
End If
[COLOR=#008000] '''Release all modifying keys, Shift, Ctrl and Alt when it was needed[/COLOR]
For Each nextKey In Split(Mid(modKeys, 2), ",")
[COLOR=#008000] '''extended keys: AltR,CtrlR,WinL,WinR,App[/COLOR]
extKey = -(InStr(" 165 163 091 092 093 ", nextKey) > 0)
' If nextKey = 165 Then nextKey = 164[COLOR=#008000] '''AltR using AltL+ext.key (otherwise CtrlL is pressed also = AltGr), though not on all pc's!!![/COLOR]
Keybd_event nextKey, 0, KBE_KeyUp + extKey, 0 [COLOR=#008000]''' ,0,, is same result as using MapVirtualKey(nextKey, 0)[/COLOR]
Next
If Right(modKeys, 1) <> " " Then[COLOR=#008000] '''no space at the end means modifying keys were only needed once[/COLOR]
modKeys = Left(modKeys, InStrRev(RTrim(modKeys), " "))[COLOR=#008000] '''remove last added group[/COLOR]
End If
End If
Loop Until keyStrokes = "" [COLOR=#008000]'''do until nothing to process anymore[/COLOR]
End Function
Function fLocalTime(Optional formatString_§tenth_§§hundredth_§§§thousandthOfSeconds) As String [COLOR=#008000]'''14/05/2013, michel(dot)be(a)gmail....
'''Return local date & time with milliseconds.
'''For format see http://msdn.microsoft.com/en-us/library/office/gg251755(v=office.14).aspx
''' + §§§ for thousandth, §§ for hundredth, § for tenth of a second
'''default= "YYYY/MM/DD HH:MM:SS.§§§"
[/COLOR]xPar1 = formatString_§tenth_§§hundredth_§§§thousandthOfSeconds[COLOR=#008000] '''smaller variable for parameter 1[/COLOR]
Dim SYSTEMTIME As SYSTEMTIME
GetLocalTime SYSTEMTIME [COLOR=#008000]'''get systemTime from Lib "kernel32" (lpSystemTime As SYSTEMTIME)[/COLOR]
vDate = SYSTEMTIME.wYear & "/" & SYSTEMTIME.wMonth & "/" & SYSTEMTIME.wDay
vTime = SYSTEMTIME.wHour & ":" & SYSTEMTIME.wMinute & ":" & SYSTEMTIME.wSecond
If isMissing(xPar1) Then[COLOR=#008000] '''default output format "YYYY/MM/DD HH:MM:SS.§§§" where §§§ = milliseconds[/COLOR]
fLocalTime = Format(vDate & " " & vTime, "YYYY/MM/DD HH:MM:SS") & "." & Format(SYSTEMTIME.wMilliseconds, "000")
Else [COLOR=#008000]'''user defined output format with §§§ for milliseconds[/COLOR]
fLocalTime = Format(vDate & " " & vTime, xPar1)
fLocalTime = Replace(fLocalTime, "§§§", Format(SYSTEMTIME.wMilliseconds, "000"))[COLOR=#008000] '''thousandth[/COLOR]
fLocalTime = Replace(fLocalTime, "§§", Format(Round(SYSTEMTIME.wMilliseconds / 10), "00"))[COLOR=#008000] '''hundredth[/COLOR]
fLocalTime = Replace(fLocalTime, "§", Round(SYSTEMTIME.wMilliseconds / 100)) [COLOR=#008000]'''tenth[/COLOR]
End If
End Function
Private Sub test_fTimer()
fTimer[COLOR=#008000] '''start stopwatch[/COLOR]
stopwatch = fTimer(False)[COLOR=#008000] '''returns the seconds.milliseconds that have elapsed, stopwatch keeps running[/COLOR]
localTime = fTimer(0.5) [COLOR=#008000]'''wait 0.5 second then returns local time[/COLOR]
timeDifference = fTimer(localTime)[COLOR=#008000] '''returns the difference in time as seconds.milliseconds[/COLOR]
stopwatch = fTimer[COLOR=#008000] '''same as True, returns the seconds.milliseconds that have elapsed and reset the stopwatch[/COLOR]
startTime = fTimer(0)[COLOR=#008000] '''returns present local time[/COLOR]
For i = 1 To 10
[COLOR=#008000] 'For Z = 1 To 10000000: Next[/COLOR]
fTimer 0.005 [COLOR=#008000]'''wait 5 milliseconds[/COLOR]
MSG = MSG & Chr(13) & fTimer(startTime) [COLOR=#008000]'''count time up for each loop[/COLOR]
Next
MsgBox MSG
MsgBox fLocalTime("H\uM\mS\s + §") & " tenth of a seconds" [COLOR=#008000]'''returns time in user difined format[/COLOR]
End Sub
Function fTimer(Optional strDifWith_misDifLastCall_falseDifLastCallNoReset_doubleWaitSecRetTime) As String[COLOR=#008000] '''05/05/2013, michel(dot)be(a)gmail....[/COLOR]
[COLOR=#008000]'''Returns elapsed time in seconds.milliseconds between calls: fTimer ... msgbox fTimer
'''or elapsed time between given date+time when called: v=fTimer(0) ... msgbox fTimer(v)
'''or waits for seconds.milliseconds if a number is provided and then returns "yyyy/mm/dd hh:mm:ss.mil"
[/COLOR]xPar1 = strDifWith_misDifLastCall_falseDifLastCallNoReset_doubleWaitSecRetTime[COLOR=#008000] '''smaller variable for parameter 1[/COLOR]
Static staticDateTime As Date, staticMSec As Single [COLOR=#008000]'''keeps last date+time and milliseconds for stopwatch[/COLOR]
Dim oldDateTime As Date, oldMSec As Single
Dim newDateTime As Date, newMSec As Single
Dim difDateTime As Date, difMSec As Single
vLocalTime = fLocalTime [COLOR=#008000]'''returns standard YYYY/MM/DD HH:MM:SS.MIL[/COLOR]
newDateTime = Left(vLocalTime, 19) [COLOR=#008000]'''extract date+time[/COLOR]
newMSec = Val(Right(vLocalTime, 3)) [COLOR=#008000]'''extract milliseconds[/COLOR]
If IsNumeric(xPar1) And TypeName(xPar1) <> "Boolean" Then[COLOR=#008000] '''wait for some seconds.milliseconds, then return present date+time.milliseconds[/COLOR]
If xPar1 > 99 Then xPar1 = xPar1 / 1000[COLOR=#008000] '''more then 99 seconds then it's probably in milliseconds[/COLOR]
difDateTime = newDateTime + TimeSerial(0, 0, Int(xPar1)) [COLOR=#008000]'''Calculate date+time to wait for,[/COLOR]
difMSec = newMSec + (xPar1 - Int(xPar1)) * 1000 [COLOR=#008000]'''and calculate milliseconds to wait for.[/COLOR]
If difMSec > 999 Then [COLOR=#008000]'''If there is one more seconds in milliseconds,[/COLOR]
difMSec = difMSec - 1000 [COLOR=#008000]'''extract 1 second from milliseconds,[/COLOR]
difDateTime = difDateTime + TimeSerial(0, 0, 1)[COLOR=#008000] '''add 1 second to time.[/COLOR]
End If
Do [COLOR=#008000]'''wait for the calculated time[/COLOR]
vLocalTime = fLocalTime [COLOR=#008000]'''returns YYYY/MM/DD HH:MM:SS.MIL[/COLOR]
newDateTime = Left(vLocalTime, 19) [COLOR=#008000]'''extract date+time[/COLOR]
newMSec = Val(Right(vLocalTime, 3))[COLOR=#008000] '''extrat milliseconds[/COLOR]
Loop Until newDateTime > difDateTime Or (newDateTime = difDateTime And newMSec >= difMSec)
fTimer = Format(newDateTime, "YYYY/MM/DD HH:MM:SS") & "." & Format(newMSec, "000") [COLOR=#008000]'''return date+time.milliseconds[/COLOR]
Else
If TypeName(xPar1) = "String" Then[COLOR=#008000] '''possible date and time given[/COLOR]
If InStr(xPar1, ":") Then[COLOR=#008000] '''Parameter with time, calculate time-difference with this[/COLOR]
oldDateTime = Left(xPar1, InStr(xPar1 & ".", ".") - 1) [COLOR=#008000]'''extract date & time without milliseconds[/COLOR]
oldMSec = Round(Val(Mid(xPar1, InStr(xPar1 & ".", "."))), 3) * 1000 [COLOR=#008000]'''extract milliseconds[/COLOR]
End If
Else [COLOR=#008000]'''missing or boolean = stopwatch, timedifferences between calls[/COLOR]
oldDateTime = staticDateTime [COLOR=#008000]'''get previous date+time[/COLOR]
oldMSec = staticMSec [COLOR=#008000]'''get previous milliseconds[/COLOR]
If isMissing(xPar1) Then xPar1 = True
If xPar1 Or (staticDateTime = 0 And staticMSec = 0) Then [COLOR=#008000]'''reset stopwatch[/COLOR]
staticDateTime = newDateTime [COLOR=#008000]'''store previous date+time[/COLOR]
staticMSec = newMSec[COLOR=#008000] '''store previous milliseconds[/COLOR]
End If
End If
If oldDateTime = 0 And oldMSec = 0 Then
[COLOR=#008000]'''=first run, only initialise with returning zero time[/COLOR]
Else [COLOR=#008000]'''possible correction of seconds and milliseconds[/COLOR]
If newMSec < oldMSec Then [COLOR=#008000]'''if the next milliseconds is a lower number then substract 1 more second[/COLOR]
difDateTime = newDateTime - oldDateTime - TimeValue("00:00:01")
difMSec = 1000 + newMSec - oldMSec
Else[COLOR=#008000] '''just substract both time a milliseconds from previous[/COLOR]
difDateTime = newDateTime - oldDateTime
difMSec = newMSec - oldMSec
End If
End If
fTimer = Hour(difDateTime) * 3600 + Minute(difDateTime) * 60 + Second(difDateTime) & "." & Format(difMSec, "000") [COLOR=#008000]'''returns seconds.milliseconds[/COLOR]
[COLOR=#008000] 'fTimer = format(difDateTime, "HH:MM:SS") & "." & format(difMSec, "000") '''returns time.milliseconds
[/COLOR] End If
End Function
