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