MsgBox that waits for user input

[Jaafar Tribak]

Hello everyone,

As we know, a MsgBox is modal, ie: halts code execution and blocks the excel user interface while it is on display.

Whereas a modeless userform allows user interaction, but doesn't halt the execution of the caller code :

Dim oForm As New UserForm1
oForm.Show vbModeless
MsgBox "The Modeless UserForm doesn't halt code execution."

It would be nice to have a MsgBox that would halt the execution of code, while at the same time, would allow user interaction with excel and would wait for any possible user input.

To this end, I have written the following UI_MsgBox function:

File Demo:
ModelessWaitingMsgBox.xlsm


In a Standard Module:

Option Explicit

#If Win64 Then
    Private Const NULL_PTR = 0^
    Private Const PTR_LEN = 8&
#Else
    Private Const NULL_PTR = 0&
    Private Const PTR_LEN = 4&
#End If
 
 #If VBA7 Then
    #If Win64 Then
        Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongPtrA" (ByVal hWnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
    #Else
        Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
    #End If
    Private Declare PtrSafe Function MessageBox Lib "user32" Alias "MessageBoxW" (ByVal hWnd As LongPtr, ByVal lpText As LongPtr, ByVal lpCaption As LongPtr, ByVal wType As Long) As Long
    Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
    Private Declare PtrSafe Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As LongPtr, ByVal hmod As LongPtr, ByVal dwThreadId As Long) As LongPtr
    Private Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" (ByVal hhk As LongPtr) As Long
    Private Declare PtrSafe Function CallNextHookEx Lib "user32" (ByVal hHook As LongPtr, ByVal nCode As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr
    Private Declare PtrSafe Function GetCurrentThreadId Lib "kernel32" () As Long
    Private Declare PtrSafe Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hWnd As LongPtr, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
    Private Declare PtrSafe Function SetTimer Lib "user32" (ByVal hWnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
    Private Declare PtrSafe Function KillTimer Lib "user32" (ByVal hWnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
    Private Declare PtrSafe Function MoveWindow Lib "user32" (ByVal hWnd As LongPtr, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal bRepaint As Long) As Long
    Private Declare PtrSafe Function IsWindowVisible Lib "user32" (ByVal hWnd As LongPtr) As Long
    Private Declare PtrSafe Function IsIconic Lib "user32" (ByVal hWnd As LongPtr) As Long
    Private Declare PtrSafe Function SendInput Lib "USER32.DLL" (ByVal cInputs As Long, pInputs As Any, ByVal cbSize As Integer) As Long
#Else
    Private Enum LongPtr
        [_]
    End Enum
    Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
    Private Declare PtrSafe Function MessageBox Lib "user32" Alias "MessageBoxW" (ByVal hWnd As LongPtr, ByVal lpText As LongPtr, ByVal lpCaption As LongPtr, ByVal wType As Long) As Long
    Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
    Private Declare PtrSafe Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As LongPtr, ByVal hmod As LongPtr, ByVal dwThreadId As Long) As LongPtr
    Private Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" (ByVal hhk As LongPtr) As Long
    Private Declare PtrSafe Function CallNextHookEx Lib "user32" (ByVal hHook As LongPtr, ByVal nCode As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr
    Private Declare PtrSafe Function GetCurrentThreadId Lib "kernel32" () As Long
    Private Declare PtrSafe Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hWnd As LongPtr, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
    Private Declare PtrSafe Function SetTimer Lib "user32" (ByVal hWnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
    Private Declare PtrSafe Function KillTimer Lib "user32" (ByVal hWnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
    Private Declare PtrSafe Function MoveWindow Lib "user32" (ByVal hWnd As LongPtr, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal bRepaint As Long) As Long
    Private Declare PtrSafe Function IsWindowVisible Lib "user32" (ByVal hWnd As LongPtr) As Long
    Private Declare PtrSafe Function IsIconic Lib "user32" (ByVal hWnd As LongPtr) As Long
    Private Declare PtrSafe Function SendInput Lib "USER32.DLL" (ByVal cInputs As Long, pInputs As Any, ByVal cbSize As Integer) As Long
#End If

Private Type KEYBDINPUT
    wVk              As Integer
    wScan            As Integer
    dwFlags          As Long
    time             As Long
    #If Win64 Then
        dwExtraInfo  As LongPtr
    #Else
        dwExtraInfo  As Long
    #End If
    padding          As Currency
End Type

Private Type tagINPUT
    INPUTTYPE        As Long
    ki               As KEYBDINPUT
End Type

Private hHook As LongPtr


Public Function UI_MsgBox( _
    ByVal Prompt As String, _
    Optional ByVal Buttons As VbMsgBoxStyle = vbOKOnly, _
    Optional ByVal Title As String _
) As VbMsgBoxResult

    Const WH_CBT = 5&
    If Len(Title) = 0& Then Title = Application.Name
    hHook = SetWindowsHookEx(WH_CBT, AddressOf HookProc, NULL_PTR, GetCurrentThreadId)
    UI_MsgBox = MessageBox(NULL_PTR, StrPtr(Prompt), StrPtr(Title), Buttons)
    Call UnhookWindowsHookEx(hHook)
End Function

' ________________________________________ Private Routines ___________________________________________

Private Function HookProc(ByVal idHook As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
    Const HCBT_ACTIVATE = 5&
    Dim sBuff As String * 256&, lRet As Long
    Dim pFakeFuncAddr As LongPtr, pTimerProcAddr As LongPtr
  
    If idHook = HCBT_ACTIVATE Then
        lRet = GetClassName(wParam, sBuff, 256&)
        If Left(sBuff, lRet) = "#32770" Then
            Call UnhookWindowsHookEx(hHook)
            pFakeFuncAddr = Choose(1&, AddressOf TimerProc)
            #If Win64 Then
                pFakeFuncAddr = Choose(1&, AddressOf FakeProc)
                pTimerProcAddr = Choose(1&, AddressOf TimerProc)
                Call SwapMemoryAdresses(pFakeFuncAddr, pTimerProcAddr)
            #End If
            Call SetTimer(wParam, wParam, 0&, pFakeFuncAddr)
        End If
    End If
    HookProc = CallNextHookEx(hHook, idHook, ByVal wParam, ByVal lParam)
End Function

Private Sub TimerProc(ByVal hWnd As LongPtr, ByVal wMsg As Long, ByVal nIDEvent As LongPtr, ByVal wTime As Long)
    Const GWLP_HWNDPARENT = (-8&)
    If IsWindowVisible(hWnd) Then
        Call KillTimer(hWnd, nIDEvent)
        Call SetWindowLong(hWnd, GWLP_HWNDPARENT, Application.hWnd)
        Call PressESCKey
        Call ProcessQueueEvents(hWnd)
    End If
End Sub

Private Sub FakeProc()
   '
End Sub

Private Sub ProcessQueueEvents(ByVal hWnd As LongPtr)
    Do: DoEvents: Loop Until IsWindowVisible(hWnd) = 0& And IsIconic(Application.hWnd) = 0&
End Sub

Private Function SwapMemoryAdresses(ByVal Addrss1 As LongPtr, ByVal Addrss2 As LongPtr)
    'https://github.com/cristianbuse/VBA-UserForm-MouseScroll/issues/28#issuecomment-1759653218
    Call CopyMemory(ByVal Addrss1 + PTR_LEN * 6& + 4&, ByVal Addrss2 + PTR_LEN * 6& + 4&, PTR_LEN)
End Function

Private Sub PressESCKey()
    Const KEYEVENTF_KEYUP = &H2, KEYEVENTF_UNICODE = &H4, VK_ESCAPE = &H1B
    ReDim InputArray(2&) As tagINPUT
    InputArray(0&).INPUTTYPE = 1&
    InputArray(0&).ki.wVk = VK_ESCAPE
    InputArray(0&).ki.dwFlags = KEYEVENTF_UNICODE
    InputArray(1&).INPUTTYPE = 1&
    InputArray(1&).ki.wVk = VK_ESCAPE
    InputArray(1&).ki.dwFlags = KEYEVENTF_UNICODE + KEYEVENTF_KEYUP
    Call SendInput(2&, InputArray(0&), LenB(InputArray(0&)))
End Sub

Code Usage Test:

Option Explicit

Public Sub Test()

    Dim sPrompt As String, lRet As VbMsgBoxResult
    
    sPrompt = sPrompt & "_ This MsgBox halts code execution but doesn't block the User Interface." & vbLf & vbLf & _
              "_ The user can work with excel while the MsgBox is shown." & vbLf & vbLf & _
              "_ The MsgBox will wait for any user input and will resume code execution when closed." & vbLf & vbLf & _
              "[For testing]" & vbLf & _
              "Edit cell ' A1 ' and the MsgBox will return the new cell value."
    
    lRet = UI_MsgBox(sPrompt, vbInformation + vbOKCancel)
 
    If lRet = vbOK Then
        MsgBox "New value in cell 'A1' is:  '" & [A1] & "'"
    End If
    
End Sub

Tested in x32 and x64 excel 2013/2016.

 

[Artik]

And so I took more from you than I gave to you. I'm the one to thank.

Artik

 

[sancarn]

Jaafar

1. I never knew any of this was possible Congrats, very impressive. It's also impressive that unhooking the window literally unhooks the whole msgbox runtime too.
2. I'm not at all sure still how the return value of msgbox actually returns... I would have imagined after destroying the hook with unhook, the return value for messagebox would also disappear. It's crazy this works...
3. I've been trying for a year or two to get SendInput working. Looks like my UDT was wrong perhaps...
4. On the topic of sendkeys, I have no idea what sending the escape key does... Could you ellaborate?

All in all, thanks so much for this example, and great job!!

 

[Jaafar Tribak]

Jaafar

1. I never knew any of this was possible Congrats, very impressive. It's also impressive that unhooking the window literally unhooks the whole msgbox runtime too.
All in all, thanks so much for this example, and great job!!

Hi sancarn,

First off, thanks for your interest and for the encouragement and sorry for not getting back sooner. I was busy exploring some api redirection techniques and how they could be used in vba without much trouble I would love to know what you think. Is the idea worthwhile? Is it stable enough when applied in a vba envirenement?

I've been trying for a year or two to get SendInput working. Looks like my UDT was wrong perhaps...

I too was having issues getting the KEYBDINPUT udt alignement /padding right but after some trial and error, I managed to figure it out so it works in both, x32 and x64.

Regarding the escape key thing, It is because when running the test code from a button, (not from the vbe or shapes), I noticed that the cursor sometimes changes to a cross or brievely disappears. Pressing the esc key seems to restore the cursor back to normal. Not a major issue but was kind of annoying.

Regards.

 

[sancarn]

Regarding the escape key thing, It is because when running the test code from a button, (not from the vbe or shapes), I noticed that the cursor sometimes changes to a cross or brievely disappears. Pressing the esc key seems to restore the cursor back to normal. Not a major issue but was kind of annoying.

Oh! xD I expected it to be deeper than something like that lol Hence why it wasn't mentioned I suppose

I too was having issues getting the KEYBDINPUT udt alignement /padding right but after some trial and error, I managed to figure it out so it works in both, x32 and x64.

So I found out what the issue was, at least in my case I was using the following UDT:

Private Type KeyboardInput
  iType As Long    'DWORD = INPUT_KEYBOARD
  wVk As Integer   'WORD
  wScan As Integer 'WORD
  dwFlags As Long  'DWORD
  time As Long     'DWORD
  #If VBA7 Then    'ULONG_PTR
    dwExtraInfo As LongPtr
  #Else
    dwExtraInfo As Long
  #End If
End Type

Turns out when you actually seperate this out into 2 seperate UDTs

Private Type KeyboardInputEx
  wVk As Integer   'WORD
  wScan As Integer 'WORD
  dwFlags As Long  'DWORD
  time As Long     'DWORD
  #If VBA7 Then    'ULONG_PTR
    dwExtraInfo As LongPtr
  #Else
    dwExtraInfo As Long
  #End If
End Type
Private Type KeyboardInput
  iType As Long    'DWORD = INPUT_KEYBOARD
  ki as KeyboardInputEx
End Type

This is enough to make SendInput start working. Now I'm at a bit of a loss as to what VBA is doing behind the scenes as it was my assumption the UDT is entirely serialised and there shouldn't be any real difference between these 2 structs... But I guess there must be some difference in reality...

 

[Jaafar Tribak]

@sancarn

. Now I'm at a bit of a loss as to what VBA is doing behind the scenes as it was my assumption the UDT is entirely serialised and there shouldn't be any real difference between these 2 structs... But I guess there must be some difference in reality...

This is how I visualize what's happening.

Per MSDN:

typedef struct tagINPUT {
DWORD type;
union {
MOUSEINPUT mi;
KEYBDINPUT ki;
HARDWAREINPUT hi;
} DUMMYUNIONNAME;
} INPUT, *PINPUT, *LPINPUT;


typedef struct tagMOUSEINPUT {
LONG dx;
LONG dy;
DWORD mouseData;
DWORD dwFlags;
DWORD time;
ULONG_PTR dwExtraInfo;
} MOUSEINPUT, *PMOUSEINPUT, *LPMOUSEINPUT;


The size of the above union is the size of the tagMOUSEINPUT element because it is the largest one: ( 7 * 4 )+ 4 bytes to align the data at 8 bytes intervals.

Type KEYBDINPUT
    wVk                 As Integer   ' WORD
    wScan               As Integer   ' WORD
    dwFlags             As Long      ' DWORD
    time                As Long      ' DWORD
    #If VBA7 Then       ' ULONG_PTR
        dwExtraInfo     As LongPtr
    #Else
        dwExtraInfo     As Long
    #End If
    padding             As LongPtr   ' Adding 8 bytes to get to same size as MOUSEINPUT Union element.
End Type

Type tagINPUT
    INPUTTYPE        As Long
    ki               As KEYBDINPUT
End Type

In x64:

* The size of the KEYBDINPUT UDT is (7 *4) + (4 Bytes needed to align the structure to 8 byte bounderies)==> (Total size = 32 bytes)
* The size of the tagINPUT UDT is then (4+ 32) + (4 Bytes needed to align the structure to 8 byte bounderies) ==> (Total size = 40 bytes)

In memory, there are 4 bytes allocated after (INPUTTYPE As Long) and before (ki As KEYBDINPUT) so, in order to use the KeyboardInput UDT the way you did, you should make up for those 4 bytes by adding a Long as a second member:

Private Type KEYBDINPUT
    iType               As Long      ' DWORD = INPUT_KEYBOARD
    Filler              As Long      ' Adding 4 Bytes to align the tagINPUT udt @8 bytes intervals.
    wVk                 As Integer   ' WORD
    wScan               As Integer   ' WORD
    dwFlags             As Long      ' DWORD
    time                As Long      ' DWORD
    #If VBA7 Then       ' ULONG_PTR
        dwExtraInfo     As LongPtr
    #Else
        dwExtraInfo     As Long
    #End If
    padding             As LongPtr   ' Adding 8 bytes to get to same size as the MOUSEINPUT Union element.
End Type

in x64

Same logic should apply to x32 except that data alignment should be 4 bytes.