SendKeys working now, can even clear immediate window and uses milliseconds counter.

onidarbe

Board Regular
Joined
Mar 22, 2013
Messages
64
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.

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
 

Some videos you may like

Excel Facts

Workdays for a market open Mon, Wed, Friday?
Yes! Use "0101011" for the weekend argument in NETWORKDAYS.INTL or WORKDAY.INTL. The 7 digits start on Monday. 1 means it is a weekend.

onidarbe

Board Regular
Joined
Mar 22, 2013
Messages
64
update:

Note: My Function and Sub-names now all ends on §
With this suffix the benefits are:
• Easier readable VBA by distinguish coded procedures with build-in ones, which is the main problem for new (hobby)programmers.
• You can just type the name and press Ctrl+Space so the special character will automatically be filled in.
• Makes the names shorter then using several letters because only a "s" for Sub could be also a String and subName() > Name$()
• Because it is a suffix instead of a prefix, one can type the first letter in the VBE Procedure pull-down list to navigate.
• But most of all, because they give less chance on conflicts with names of standard VBA functions, methods, properties, ...

Please leave a message, thanks or any remark.


Code:
Private Enum enumKBE [COLOR=#00A000]'''Sub Keybd_event[/COLOR]     KBE_KeyDown = 0
     KBE_KeyUp = 2
     KBE_ExtKeyDown = 1
     KBE_ExtKeyUp = 3
End Enum
Private Type SYSTEMTIME [COLOR=#00A000]'''Sub GetLocalTime[/COLOR]
     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=#00A000]'''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=#00A000]'''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=#00A000]'''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=#00A000]'''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=#00A000]'''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=#00A000]'''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=#00A000]'''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=#00A000]'''Retrieves the current local date and time with milliseconds.[/COLOR]
#Else
    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)
#End If


Private Sub test_fSendKeys()
[COLOR=#00A000]'    fTimer§ 1000 '''enable pressing Alt after starting this sub[/COLOR]
[COLOR=#00A000]'    SendKeys§ "%({tab}{tab})" '''switch to 3th application[/COLOR]
[COLOR=#00A000]'    SendKeys§ "{win}e" '''open new windows-explorer[/COLOR]
[COLOR=#00A000]'    SendKeys§ "{ctrl}(g{end}){F7}" '''switch to Immediate window, set cursor to last line and come back to vba-code[/COLOR]
    SendKeys§ "^(g{home}+{end}){del}" [COLOR=#00A000]'''clear Immediate window[/COLOR]
End Sub


Function SendKeys§(Optional ByVal keyStrokes As String, Optional waitMilliseconds As Integer) [COLOR=#00A000]'''04/08/2013, michel(dot)be(a)gmail....[/COLOR]
[COLOR=#00A000]'''Simulates key-strokes without changing the already pressed modifying keys[/COLOR]
[COLOR=#00A000]'''Note: The VBA build-in SendKeys is not reliable, like it messes up the Num-, Shift- and Scroll-Lock state![/COLOR]
[COLOR=#00A000]'''Differences with the VBA build in SendKeys. http://msdn.microsoft.com/en-us/library/office/ff821075.aspx[/COLOR]
[COLOR=#00A000]'''     Pauses with DoEvents using "{milliSeconds}", max 30000, min 2 characters as in {01} (=1 millisecond)[/COLOR]
[COLOR=#00A000]'''     To send a special or any character as the character itself, place in in {}: {^} {+} {{} {)} {~} {1}...[/COLOR]
[COLOR=#00A000]'''     {Ctrl} or ^, {Alt} or %, {Shift} or +, {Win}, {Apps}, {CtrlR}, {ShiftR},... will hold down that modifying key while pressing next key[/COLOR]
[COLOR=#00A000]'''     Use () to know the end using the last group of modifying keys.[/COLOR]
[COLOR=#00A000]'''{NumLock}, {ShiftLock}, {ScrollLock}, {Insert} will swap state, so check state first with CBool(GetKeyState(vbKeyNumlock) And 1)[/COLOR]
[COLOR=#00A000]'''ATTENTION: Don't debug this function using the keys Shift, Ctrl and Alt, but use the debug-bar-buttons !!!![/COLOR]
[COLOR=#00A000]'''           If you get stuck, press every L & R modifying key ones.[/COLOR]
[COLOR=#00A000]'''REMARKS ON SENDING TO EXCEL: SendKeys "^v" or "^z" or "^y": DoEvents clears undo/redo! use .OnTime[/COLOR]
[COLOR=#00A000]'''                             SendKeys "text{return}": DoEvents doesn't add to undo! use .OnTime[/COLOR]
[COLOR=#00A000]'''Thanks to Bryan Wolf, Chip Pearson and many others on the net for info ;-)[/COLOR]
[COLOR=#00A000]'''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=#00A000]'''take first character...[/COLOR]
        keyStrokes = Mid(keyStrokes, 2) [COLOR=#00A000]'''...and delete first character from list to process[/COLOR]
        If nextKey = "{" Then [COLOR=#00A000]'''handle everything in between "{" and "}"[/COLOR]
            nextKey = Split(keyStrokes, "}")(0) [COLOR=#00A000]'''grab key-name till next "}" or till end of string!!![/COLOR]
            If Left(keyStrokes, 2) = "}}" Then nextKey = "}" [COLOR=#00A000]'''it's "}" instead of "", because it was "{}}" not "{}"[/COLOR]
            keyStrokes = Mid(keyStrokes, Len(nextKey) + 2) [COLOR=#00A000]'''delete the key + "}" from the list to process[/COLOR]
            If Len(nextKey) > 1 Then specialKey = nextKey [COLOR=#00A000]'''more then 1 character = special key-name[/COLOR]
        ElseIf nextKey = "(" And Left(keyStrokes, 1) = ")" Then [COLOR=#00A000]''' found "()", go and send only present modKeys[/COLOR]
            nextKey = ""
            keyStrokes = Mid(keyStrokes, Len(nextKey) + 2) [COLOR=#00A000]'''delete ")" from the list to process[/COLOR]
        ElseIf InStr("+^%~()", nextKey) Then
            specialKey = nextKey
        End If
        Select Case UCase(specialKey) [COLOR=#00A000]'''http://msdn.microsoft.com/en-us/library/windows/desktop/dd375731.aspx[/COLOR]
            Case "" [COLOR=#00A000]'''send the actual ascII key, even if it's "" or one of these +^%~(){} as actual ascII key[/COLOR]
                CharToOem nextKey, str2Char [COLOR=#00A000]'''Fill str2Char with the character translation. str2Char need to as string*2 ![/COLOR]
                scanCode = OemKeyScan(Asc(str2Char))  [COLOR=#00A000]'''Maps OemASCII*2 codes into the OEM scancodes and shiftstates.[/COLOR]
                If nextKey <> "" Then
                    keyCode = VkKeyScan(Asc(nextKey)) [COLOR=#00A000]'''Translates character to virtual keycode and modifying-key-state.[/COLOR]
                    If (keyCode And &H100) Then modKeys = modKeys & ",016" [COLOR=#00A000]'''Shift needs to be down for this character[/COLOR]
                    If (keyCode And &H200) Then modKeys = modKeys & ",017" [COLOR=#00A000]''' Ctrl needs to be down for this character[/COLOR]
                    If (keyCode And &H400) Then modKeys = modKeys & ",018" [COLOR=#00A000]'''  Alt needs to be down for this character[/COLOR]
                End If
            Case "(":           modKeys = modKeys & " " [COLOR=#00A000]'''use a space to mark the next group between brackets[/COLOR]
            Case ")":           modKeys = Left(modKeys, InStrRev(RTrim(modKeys), " ")) [COLOR=#00A000]'''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=#00A000]'''=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=#00A000]'''=ext.key[/COLOR]
            Case "LWIN", "WINL":                            modKeys = modKeys & ",091" [COLOR=#00A000]'''=ext.key[/COLOR]
            Case "RWIN", "WINR":                            modKeys = modKeys & ",092" [COLOR=#00A000]'''=ext.key[/COLOR]
            Case "APPS":                                    modKeys = modKeys & ",093" [COLOR=#00A000]'''=ext.key, no L/R version !!![/COLOR]
            Case "WIN":                                     modKeys = modKeys & ",094" [COLOR=#00A000]'''=reserved key!!![/COLOR]
            [COLOR=#00A000]'''lock-keys[/COLOR]
            Case "PAUSE":                               keyCode = vbKeyPause   [COLOR=#00A000]'''19[/COLOR]
            Case "CAPSLOCK", "SHIFTLOCK", "CAPS":       keyCode = vbKeyCapital [COLOR=#00A000]'''20[/COLOR]
            Case "INSERT", "INS":                       keyCode = vbKeyInsert  [COLOR=#00A000]'''45 =ext.key[/COLOR]
            Case "NUMLOCK":                             keyCode = vbKeyNumlock [COLOR=#00A000]'''144 =ext.key[/COLOR]
            Case "SCROLLLOCK", "SCROLL":                keyCode = &H91         [COLOR=#00A000]'''145[/COLOR]
            [COLOR=#00A000]'''[/COLOR]
            Case "BREAK", "CANCEL":                     keyCode = vbKeyCancel   [COLOR=#00A000]'''3[/COLOR]
            Case "BACKSPACE", "BACK", "BS":             keyCode = vbKeyBack     [COLOR=#00A000]'''8[/COLOR]
            Case "TAB":                                 keyCode = vbKeyTab      [COLOR=#00A000]'''9[/COLOR]
            Case "LF":                                  keyCode = vbLf          [COLOR=#00A000]'''10[/COLOR]
            Case "CLEAR":                               keyCode = vbKeyClear    [COLOR=#00A000]'''12[/COLOR]
            Case "RETURN", "~":                         keyCode = vbKeyReturn   [COLOR=#00A000]'''13[/COLOR]
            Case "ESC", "ESCAPE":                       keyCode = vbKeyEscape   [COLOR=#00A000]'''27[/COLOR]
            Case "SPACE":                               keyCode = vbKeySpace    [COLOR=#00A000]'''32[/COLOR]
            Case "SELECT":                              keyCode = vbKeySelect   [COLOR=#00A000]'''41[/COLOR]
            Case "PRINT":                               keyCode = vbKeyPrint    [COLOR=#00A000]'''42[/COLOR]
            Case "EXECUTE":                             keyCode = vbKeyExecute  [COLOR=#00A000]'''43[/COLOR]
            Case "SNAPSHOT", "PRTSC", "PRINTSCREEN":    keyCode = vbKeySnapshot [COLOR=#00A000]'''44 =ext.key[/COLOR]
            Case "DELETE", "DEL":                       keyCode = vbKeyDelete   [COLOR=#00A000]'''46 =ext.key[/COLOR]
            Case "HELP":                                keyCode = vbKeyHelp     [COLOR=#00A000]'''47[/COLOR]
           [COLOR=#00A000]'''cursor[/COLOR]
            Case "PAGEUP", "PGUP", "PRIOR":             keyCode = vbKeyPageDown [COLOR=#00A000]'''33 =ext.key[/COLOR]
            Case "PAGEDOWN", "PGDN", "NEXT":            keyCode = vbKeyPageUp   [COLOR=#00A000]'''34 =ext.key[/COLOR]
            Case "END":                                 keyCode = vbKeyEnd      [COLOR=#00A000]'''35 =ext.key[/COLOR]
            Case "HOME":                                keyCode = vbKeyHome     [COLOR=#00A000]'''36 =ext.key[/COLOR]
            Case "LEFT":                                keyCode = vbKeyLeft     [COLOR=#00A000]'''37 =ext.key[/COLOR]
            Case "UP":                                  keyCode = vbKeyUp       [COLOR=#00A000]'''38 =ext.key[/COLOR]
            Case "RIGHT":                               keyCode = vbKeyRight    [COLOR=#00A000]'''39 =ext.key[/COLOR]
            Case "DOWN":                                keyCode = vbKeyDown     [COLOR=#00A000]'''40 =ext.key[/COLOR]
            [COLOR=#00A000]''numberic pad[/COLOR]
            Case "ENTER":                               keyCode = &H1C          [COLOR=#00A000]'''28 =ext.key[/COLOR]
            Case "NUMPAD0":                             keyCode = vbKeyNumpad0  [COLOR=#00A000]'''96[/COLOR]
            Case "NUMPAD1":                             keyCode = vbKeyNumpad1  [COLOR=#00A000]'''97[/COLOR]
            Case "NUMPAD2":                             keyCode = vbKeyNumpad2  [COLOR=#00A000]'''98[/COLOR]
            Case "NUMPAD3":                             keyCode = vbKeyNumpad3  [COLOR=#00A000]'''99[/COLOR]
            Case "NUMPAD4":                             keyCode = vbKeyNumpad4  [COLOR=#00A000]'''100[/COLOR]
            Case "NUMPAD5":                             keyCode = vbKeyNumpad5  [COLOR=#00A000]'''101[/COLOR]
            Case "NUMPAD6":                             keyCode = vbKeyNumpad6  [COLOR=#00A000]'''102[/COLOR]
            Case "NUMPAD7":                             keyCode = vbKeyNumpad7  [COLOR=#00A000]'''103[/COLOR]
            Case "NUMPAD8":                             keyCode = vbKeyNumpad8  [COLOR=#00A000]'''104[/COLOR]
            Case "NUMPAD9":                             keyCode = vbKeyNumpad9  [COLOR=#00A000]'''105[/COLOR]
            Case "MULTIPLY":                            keyCode = vbKeyMultiply [COLOR=#00A000]'''106[/COLOR]
            Case "ADD":                                 keyCode = vbKeyAdd      [COLOR=#00A000]'''107[/COLOR]
            Case "SEPARATOR":                           keyCode = vbKeySeparator [COLOR=#00A000]''108[/COLOR]
            Case "SUBTRACT":                            keyCode = vbKeySubtract [COLOR=#00A000]'''109[/COLOR]
            Case "DECIMAL":                             keyCode = vbKeyDecimal  [COLOR=#00A000]'''110[/COLOR]
            Case "DIVIDE":                              keyCode = vbKeyDivide   [COLOR=#00A000]'''111 =ext.key[/COLOR]
            [COLOR=#00A000]'''function[/COLOR]
            Case "F1":                                  keyCode = vbKeyF1       [COLOR=#00A000]'''112[/COLOR]
            Case "F2":                                  keyCode = vbKeyF2       [COLOR=#00A000]'''113[/COLOR]
            Case "F3":                                  keyCode = vbKeyF3       [COLOR=#00A000]'''114[/COLOR]
            Case "F4":                                  keyCode = vbKeyF4       [COLOR=#00A000]'''115[/COLOR]
            Case "F5":                                  keyCode = vbKeyF5       [COLOR=#00A000]'''116[/COLOR]
            Case "F6":                                  keyCode = vbKeyF6       [COLOR=#00A000]'''117[/COLOR]
            Case "F7":                                  keyCode = vbKeyF7       [COLOR=#00A000]'''118[/COLOR]
            Case "F8":                                  keyCode = vbKeyF8       [COLOR=#00A000]'''119[/COLOR]
            Case "F9":                                  keyCode = vbKeyF9       [COLOR=#00A000]'''120[/COLOR]
            Case "F10":                                 keyCode = vbKeyF10      [COLOR=#00A000]'''121[/COLOR]
            Case "F11":                                 keyCode = vbKeyF11      [COLOR=#00A000]'''122[/COLOR]
            Case "F12":                                 keyCode = vbKeyF12      [COLOR=#00A000]'''123[/COLOR]
            Case "F13":                                 keyCode = vbKeyF13      [COLOR=#00A000]'''124[/COLOR]
            Case "F14":                                 keyCode = vbKeyF14      [COLOR=#00A000]'''125[/COLOR]
            Case "F15":                                 keyCode = vbKeyF15      [COLOR=#00A000]'''126[/COLOR]
            Case "F16":                                 keyCode = vbKeyF16      [COLOR=#00A000]'''127[/COLOR]
            [COLOR=#00A000]'''mouse button[/COLOR]
            Case "LBUTTON":                             keyCode = vbKeyLButton  [COLOR=#00A000]'''1[/COLOR]
            Case "RBUTTON":                             keyCode = vbKeyRButton  [COLOR=#00A000]'''2[/COLOR]
            Case "MBUTTON":                             keyCode = vbKeyMButton  [COLOR=#00A000]'''4[/COLOR]
            Case "XBUTTON1":                            keyCode = &H5           [COLOR=#00A000]'''5[/COLOR]
            Case "XBUTTON2":                            keyCode = &H6           [COLOR=#00A000]'''6[/COLOR]
            Case 1 To 30000:   DoEvents
                                Timer§ (Val(nextKey) / 1000) [COLOR=#00A000]'''milliseconds to pause (max 30sec)[/COLOR]
            Case Else:  If MsgBox("Error in string of Key-Strokes to send!", vbExclamation + vbOKCancel _
                           , "Function Sendkeys§()") = vbCancel Then Stop
        End Select
        If keyCode > -1 Or specialKey = "" Or (keyStrokes = "" And modKeys <> "") Then [COLOR=#00A000]'''send keystroke[/COLOR]
            [COLOR=#00A000]'''Change modifying keys to the Left- or Right-equivalent, what ever is not already pressed down.[/COLOR]
            [COLOR=#00A000]'''Because otherwise the manually pressed key could rise or stays down as this function ends.[/COLOR]
            [COLOR=#00A000]'''Just in case the already pressed modifying key is released while running this function.[/COLOR]
            DoEvents [COLOR=#00A000]'''NEEDED FOR BUG: To be shure that a manual pressed modifying key can be read correctly after starting VBA-code[/COLOR]
            If CBool(GetKeyState(161) And -128) Then     [COLOR=#00A000]'''R-Shift already (manually) down...[/COLOR]
                modKeys = Replace(modKeys, "016", "160")    [COLOR=#00A000]'''...replace all Shift with L-Shift[/COLOR]
            Else
                modKeys = Replace(modKeys, "016", "161")    [COLOR=#00A000]'''replace all Shift with R-Shift[/COLOR]
            End If
            If CBool(GetKeyState(163) And -128) Then     [COLOR=#00A000]'''R-Ctrl already (manually) down...[/COLOR]
                modKeys = Replace(modKeys, "017", "162")    [COLOR=#00A000]'''...replace all Ctrl with L-Ctrl[/COLOR]
            Else
                modKeys = Replace(modKeys, "017", "163")    [COLOR=#00A000]'''replace all Ctrl with R-Ctrl[/COLOR]
            End If
            If CBool(GetKeyState(165) And -128) Then     [COLOR=#00A000]'''R-Alt already (manually) down...[/COLOR]
                modKeys = Replace(modKeys, "018", "164")    [COLOR=#00A000]'''...replace all Alt with L-Alt[/COLOR]
            Else
                modKeys = Replace(modKeys, "018", "165")    [COLOR=#00A000]'''replace all Alt with R-Alt[/COLOR]
            End If
            If CBool(GetKeyState(92) And -128) Then      [COLOR=#00A000]'''R-Win already (manually) down...[/COLOR]
                modKeys = Replace(modKeys, "094", "091")    [COLOR=#00A000]'''...replace all Win with L-Win[/COLOR]
            Else
                modKeys = Replace(modKeys, "094", "092")    [COLOR=#00A000]'''replace all Win with R-Win[/COLOR]
            End If
            [COLOR=#00A000]'''Check, wait and pop-up-message to release all modifying keys until non are pressed anymore.[/COLOR]
            startTime = Now() [COLOR=#00A000]'''get start time waiting[/COLOR]
            Do
                DoEvents
                If InStr(modKeys, 160) Or InStr(modKeys, 161) Or CBool(GetKeyState(16) And -128) = 0 Then [COLOR=#00A000]'''Shift needed or not pressed[/COLOR]
                    If InStr(modKeys, 162) Or InStr(modKeys, 163) Or CBool(GetKeyState(17) And -128) = 0 Then [COLOR=#00A000]'''Ctrl needed or not pressed[/COLOR]
                        If InStr(modKeys, 164) Or InStr(modKeys, 165) Or CBool(GetKeyState(18) And -128) = 0 Then [COLOR=#00A000]'''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=#00A000]'''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=#00A000]'''to long waiting on key-release[/COLOR]
                    If MsgBox("Please release all mouse and keyboard buttons." _
                        , vbOKCancel, "Function SendKeys§()") = vbCancel Then Exit Function
                    startTime = Now() [COLOR=#00A000]'''get start time waiting[/COLOR]
                End If
            Loop


            [COLOR=#00A000]'''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=#00A000]'''modifying key already down[/COLOR]
                    modKeys = Replace(modKeys, "," & nextKey, "") [COLOR=#00A000]'''remove that key to not rise automaticly at the end[/COLOR]
                Else [COLOR=#00A000]'''if not already pressed down push modifying key down[/COLOR]
                    [COLOR=#00A000]'''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=#00A000]'''if AltR while and CtrlL is up[/COLOR]
                        [COLOR=#00A000]'''NEEDED FOR BUG: When pressing AltR, the CtrlL also go's down on some PC's (Belgium azerty =AltGr)[/COLOR]
                        [COLOR=#00A000]'''note: MapVirtualKey(nextKey, 0) not needed, works also with 0 for modifying keys[/COLOR]
                        Keybd_event nextKey, 0, KBE_KeyDown + extKey, 0 [COLOR=#00A000]'''press AltR (AltGr)[/COLOR]
                        Keybd_event 162, 0, KBE_KeyUp, 0 [COLOR=#00A000]'''release CtrlL[/COLOR]
                    Else
                        Keybd_event nextKey, 0, KBE_KeyDown + extKey, 0
                    End If
                End If
            Next
            [COLOR=#00A000]'''Press the key while modifying keys are down[/COLOR]
            If keyCode <> -1 Then
                If scanCode = -1 Then [COLOR=#00A000]'''not a character-key but a named key, like {End}...[/COLOR]
                    scanCode = MapVirtualKey(keyCode, 0)
                    [COLOR=#00A000]'''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=#00A000]'''KBE_KeyDown=0 +1(if extended key)[/COLOR]
                Keybd_event (keyCode And &HFF), (scanCode And &HFF), KBE_KeyUp + extKey, 0   [COLOR=#00A000]'''KBE_KeyUp = 2 +1(if extended key)[/COLOR]
            End If
            
            
            [COLOR=#00A000]'''Release all modifying keys, Shift, Ctrl and Alt when it was needed[/COLOR]
            For Each nextKey In Split(Mid(modKeys, 2), ",")
                [COLOR=#00A000]'''extended keys: AltR,CtrlR,WinL,WinR,App[/COLOR]
                extKey = -(InStr(" 165 163   091  092  093 ", nextKey) > 0)
[COLOR=#00A000]'                If nextKey = 165 Then nextKey = 164 '''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=#00A000]''' ,0,, is same result as using MapVirtualKey(nextKey, 0)[/COLOR]
            Next
            
            If Right(modKeys, 1) <> " " Then [COLOR=#00A000]'''no space at the end means modifying keys were only needed once[/COLOR]
                modKeys = Left(modKeys, InStrRev(RTrim(modKeys), " ")) [COLOR=#00A000]'''remove last added group[/COLOR]
            End If
        End If
    Loop Until keyStrokes = "" [COLOR=#00A000]'''do until nothing to process anymore[/COLOR]
End Function




Function Timer§(Optional strDifWith_misDifLastCall_falseDifLastCallNoReset_doubleWaitSecRetTime) As String [COLOR=#00A000]'''05/05/2013, michel(dot)be(a)gmail....[/COLOR]
[COLOR=#00A000]'''Returns elapsed time in seconds.milliseconds between calls: Timer§ ... msgbox Timer§[/COLOR]
[COLOR=#00A000]'''or elapsed time between given date+time when called: v=fTimer(0) ... msgbox Timer§(v)[/COLOR]
[COLOR=#00A000]'''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=#00A000]'''smaller variable for parameter 1[/COLOR]
Static staticDateTime As Date, staticMSec As Single [COLOR=#00A000]'''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 = LocalTime§ [COLOR=#00A000]'''returns standard YYYY/MM/DD HH:MM:SS.MIL[/COLOR]
    newDateTime = Left(vLocalTime, 19) [COLOR=#00A000]'''extract date+time[/COLOR]
    newMSec = Val(Right(vLocalTime, 3)) [COLOR=#00A000]'''extract milliseconds[/COLOR]
    If IsNumeric(xPar1) And TypeName(xPar1) <> "Boolean" Then [COLOR=#00A000]'''wait for some seconds.milliseconds, then return present date+time.milliseconds[/COLOR]
            If xPar1 > 99 Then xPar1 = xPar1 / 1000 [COLOR=#00A000]'''more then 99 seconds then it's probably in milliseconds[/COLOR]
        difDateTime = newDateTime + TimeSerial(0, 0, Int(xPar1)) [COLOR=#00A000]'''Calculate date+time to wait for,[/COLOR]
        difMSec = newMSec + (xPar1 - Int(xPar1)) * 1000 [COLOR=#00A000]'''and calculate milliseconds to wait for.[/COLOR]
        If difMSec > 999 Then [COLOR=#00A000]'''If there is one more seconds in milliseconds,[/COLOR]
            difMSec = difMSec - 1000 [COLOR=#00A000]'''extract 1 second from milliseconds,[/COLOR]
            difDateTime = difDateTime + TimeSerial(0, 0, 1) [COLOR=#00A000]'''add 1 second to time.[/COLOR]
        End If
        Do [COLOR=#00A000]'''wait for the calculated time[/COLOR]
            vLocalTime = LocalTime§ [COLOR=#00A000]''' returns YYYY/MM/DD HH:MM:SS.MIL[/COLOR]
            newDateTime = Left(vLocalTime, 19) [COLOR=#00A000]'''extract date+time[/COLOR]
            newMSec = Val(Right(vLocalTime, 3)) [COLOR=#00A000]'''extrat milliseconds[/COLOR]
        Loop Until newDateTime > difDateTime Or (newDateTime = difDateTime And newMSec >= difMSec)
        Timer§ = Format(newDateTime, "YYYY/MM/DD HH:MM:SS") & "." & Format(newMSec, "000") [COLOR=#00A000]'''return date+time.milliseconds[/COLOR]
    Else
        If TypeName(xPar1) = "String" Then [COLOR=#00A000]'''possible date and time given[/COLOR]
            If InStr(xPar1, ":") Then  [COLOR=#00A000]'''Parameter with time, calculate time-difference with this[/COLOR]
                oldDateTime = Left(xPar1, InStr(xPar1 & ".", ".") - 1) [COLOR=#00A000]'''extract date & time without milliseconds[/COLOR]
                oldMSec = Round(Val(Mid(xPar1, InStr(xPar1 & ".", "."))), 3) * 1000 [COLOR=#00A000]'''extract milliseconds[/COLOR]
            End If
        Else [COLOR=#00A000]'''missing or boolean = stopwatch, timedifferences between calls[/COLOR]
            oldDateTime = staticDateTime [COLOR=#00A000]'''get previous date+time[/COLOR]
            oldMSec = staticMSec [COLOR=#00A000]'''get previous milliseconds[/COLOR]
            If IsMissing§(xPar1) Then xPar1 = True
            If xPar1 Or (staticDateTime = 0 And staticMSec = 0) Then [COLOR=#00A000]'''reset stopwatch[/COLOR]
                staticDateTime = newDateTime [COLOR=#00A000]'''store previous date+time[/COLOR]
                staticMSec = newMSec [COLOR=#00A000]'''store previous milliseconds[/COLOR]
            End If
        End If
        If oldDateTime = 0 And oldMSec = 0 Then
            [COLOR=#00A000]'''=first run, only initialise with returning zero time[/COLOR]
        Else [COLOR=#00A000]'''possible correction of seconds and milliseconds[/COLOR]
            If newMSec < oldMSec Then [COLOR=#00A000]'''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=#00A000]'''just substract both time a milliseconds from previous[/COLOR]
                difDateTime = newDateTime - oldDateTime
                difMSec = newMSec - oldMSec
            End If
        End If
        Timer§ = Hour(difDateTime) * 3600 + Minute(difDateTime) * 60 + Second(difDateTime) & "." & Format(difMSec, "000")   [COLOR=#00A000]'''returns seconds.milliseconds[/COLOR]
        [COLOR=#00A000]'Timer§ = format(difDateTime, "HH:MM:SS") & "." & format(difMSec, "000") '''returns time.milliseconds[/COLOR]
    End If
End Function


Function LocalTime§(Optional formatString_0tenth_00hundredth_000thousandthOfSeconds) As String [COLOR=#00A000]'''14/05/2013, michel(dot)be(a)gmail....[/COLOR]
[COLOR=#00A000]'''Return local date & time with milliseconds.[/COLOR]
[COLOR=#00A000]'''For format see http://msdn.microsoft.com/en-us/library/office/gg251755(v=office.14).aspx[/COLOR]
[COLOR=#00A000]'''           + ___ for thousandth, __ for hundredth, _ for tenth of a second[/COLOR]
[COLOR=#00A000]'''default= "YYYY/MM/DD HH:MM:SS.000"[/COLOR]
xPar1 = formatString_0tenth_00hundredth_000thousandthOfSeconds [COLOR=#00A000]'''smaller variable for parameter 1[/COLOR]
Dim SYSTEMTIME As SYSTEMTIME
    GetLocalTime SYSTEMTIME [COLOR=#00A000]'''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=#00A000]'''default output format "YYYY/MM/DD HH:MM:SS.§§§" where §§§ = milliseconds[/COLOR]
        LocalTime§ = Format(vDate & " " & vTime, "YYYY/MM/DD HH:MM:SS") & "." & Format(SYSTEMTIME.wMilliseconds, "000")
    Else [COLOR=#00A000]'''user defined output format with §§§ for milliseconds[/COLOR]
        LocalTime§ = Format(vDate & " " & vTime, xPar1)
        LocalTime§ = Replace(LocalTime§, "000", Format(SYSTEMTIME.wMilliseconds, "000")) [COLOR=#00A000]'''thousandth[/COLOR]
        LocalTime§ = Replace(LocalTime§, "00", Format(Round(SYSTEMTIME.wMilliseconds / 10), "00")) [COLOR=#00A000]'''hundredth[/COLOR]
        LocalTime§ = Replace(LocalTime§, "0", Round(SYSTEMTIME.wMilliseconds / 100)) [COLOR=#00A000]'''tenth[/COLOR]
    End If
End Function


Function IsMissing§(Optional xThis As Variant) As Boolean [COLOR=#00A000]'''10/06/2013, michel(dot)be(a)gmail....[/COLOR]
[COLOR=#00A000]'''To replace VBA build-in IsMissing(), because using IsMissing on a copy from an non-allocated array to a non-array-dimensioned variant,[/COLOR]
[COLOR=#00A000]'''will raise a fatal error that closes Excel with the message "Microsoft Excel has stopped working" !!![/COLOR]
[COLOR=#00A000]'''     Dim orgArray(), copyArray  'no error when using copyArray(), but can't use that as a parameter[/COLOR]
[COLOR=#00A000]'''     copyArray = orgArray  'seems to be an exact copy of the non-allocated array, but...[/COLOR]
[COLOR=#00A000]'''     debug.print IsMissing(copyArray)  '...IsMissing will raise a fatal error on that copy ![/COLOR]
    If IsError(xThis) Then
        If CStr(CVErr(xThis)) = "Error 448" Then IsMissing§ = True
    End If
End Function
 

Erni76

New Member
Joined
Dec 22, 2009
Messages
35
Office Version
  1. 2016
  2. 2013
  3. 2011
  4. 2010
  5. 2007
Platform
  1. Windows
Brilliant ... Awesome ... Finally, someone sorted it out :) :biggrin: (y) (y) (y) :biggrin: :)
Thank you so much and thanks to all who contributed to the code. (y) (y) (y)
I only added the following two lines on the beginning of Function Timer§ :
VBA Code:
Dim xPar1 As String
Dim vLocalTime As Date
(It is because I like all my modules to start with Option Explicit)
I do some programming but not on such a deep level.
It was very annoying that VBA SendKeys was messing up with NumLock. For years I couldn't find the solution. So far my little investigation clearly shows that every macro with the SendKeys causing the GetKeyState(vbKeyNumlock) to start returning the incorrect value. This behaviour persists until another macro with SendKeys is executed.
 

Watch MrExcel Video

Forum statistics

Threads
1,112,816
Messages
5,542,660
Members
410,567
Latest member
SCraig123
Top