F.Q.A.: A pressed key in VBA

The question:
"I have a macro with a loop (Do-Loop). When I run it I need to interrupt the running by pressing of any key (for example space), jump behind Loop and finish the macro. Is there a way how can I do it?"

I really think the writing of an endless loop in VBA isn't a good idea. Probably there exists another (better) way how to reach your targer without it. But I love challenges...

There is no "keyboard" object in VBA that's why I looked for a suitable API function. I found the SetWindowsHookEx which installs an application-defined hook procedure into a hook chain. The type of the installed procedure depends on the idHook parameter. I used WH_KEYBOARD which installs the KeyboardProc. In the description of the SetWindowsHookEx is highly recommended using of the CallNextHookEx function. And the UnhookWindowsHookEx is necessary to unhook. Furthermore for getting the identifier of the thread with which the hook procedure is associated I used the GetCurrentThreadId.

I wrote the code below. To demonstrate how it works run the subTest subroutine. There is a loop with 1.000.000 steps which does nothing. A record will be printed to the Immediate window if you press any key while the code is running. To finish the loop (and the subroutine) you can press the Space key.

Select all

Option Explicit

Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, ByVal dwThreadId As Long) As Long
Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, ByVal ncode As Long, ByVal wParam As Long, lParam As Any) As Long
Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
Declare Function GetCurrentThreadId Lib "kernel32" () As Long

Public Const WH_KEYBOARD As Byte = 2
Public Const VK_SPACE As Byte = &H20

Dim hHook As Long
Dim iVKCode As Byte
'Virtual-Key Codes - see https://msdn.microsoft.com/en-us/library/windows/desktop/dd375731(v=vs.85).aspx

Private Function fncKeyboardProc(ByVal idHook As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
  If idHook < 0 Then
    fncKeyboardProc = CallNextHookEx(hHook, idHook, wParam, ByVal lParam)
  Else
    If Left$(WorksheetFunction.Hex2Bin(Left$(WorksheetFunction.Dec2Hex(lParam, 8), 1)), 1) = "1" Then
      '"0" - a key is being pressed, "1" - a key is being released
      If Not wParam = iVKCode Then
        iVKCode = wParam
        fncKeyboardProc = 1
      End If
    Else
      iVKCode = 0
    End If
  End If
End Function

Private Sub subTest()
  Const iMAX As Long = 1000000
  
  hHook = SetWindowsHookEx(WH_KEYBOARD, AddressOf fncKeyboardProc, Application.Hinstance, GetCurrentThreadId)
  
  Dim iLastVK As Byte
  Dim i As Long
  i = 0
  While Not iVKCode = VK_SPACE And i < iMAX
    i = i + 1
    DoEvents
    
    If Not iVKCode = 0 Then
      If Not iVKCode = iLastVK Then
        Debug.Print iVKCode, """" & Chr$(iVKCode) & """"
        iLastVK = iVKCode
      End If
    Else
      iLastVK = 0
    End If
  Wend
  
  If iVKCode = VK_SPACE Then
    MsgBox "Space pressed ..."
    iVKCode = 0
  Else
    MsgBox "i = " & iMAX
  End If
  
  UnhookWindowsHookEx hHook
End Sub

Tweet