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.

 

[Joe4]

Hello Jafaar,

Thanks for sharing!
Since this really isn't a question searching for an answer, I have moved it to the Discussion forum.

Thanks,
The Moderators

 

[Jaafar Tribak]

Hello Jafaar,

Thanks for sharing!
Since this really isn't a question searching for an answer, I have moved it to the Discussion forum.

Thanks,
The Moderators

No problem. Thanks for letting me know.

 

[John_w]

Hi Jaafar, this will be really useful. Certainly far better than the userform kludge I had to use in the other thread (Excel vba to select next option in autofilter drop down menu).

Tested working fine on Excel 2021 32-bit and 64-bit.

 

[StephenCrump]

Excellent, thanks Jaaafar

Works fine for me in Excel 365 Win10 64 bit.

 

[Jaafar Tribak]

@John_w, @StephenCrump

Thank you my friends for testing and letting me know.

BTW, when posting the code, I forgot to remove the PtrSafe keyword in the api declaration section for <VBA7. I have already fixed that in the uploaded file above.

#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 .... etc ...

Regards.

 

[Artik]

Jaafar, the paint on my computer case is swelling , that's how hot the processor is.
I suggest a small change in the code. In the bas_API module, add the declaration:

#If VBA7 Then
    Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#Else
    Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#End If

and change the procedure:

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

And besides, it's excellent.

Artik

 

[Jaafar Tribak]

@Artik​

Thanks for the interest and for the suggestion.

The Sleep api won't work because it suspends the execution of the current thread, whereas DoEvents yields execution of simultaneous tasks hence allowing user interaction with excel which is the whole point of the code.

Not using DoEvents will still allow for selecting ranges/menus etc , but won't allow for editing cells which is the most important task.

Certainly, calling DoEvents in a loop will impact performance, but in this particular scenario, the loop should be very short lived and will exit the moment the MsgBox is dismissed. So I think, it is not really something to worry about.

Regards.

PS: It is worth noting that the only task that DoEvents impedes is cell DragNDrop operations. For some misterious reason, that functionality is affected.

 

[Artik]

The Sleep api won't work because it suspends the execution of the current thread, whereas DoEvents yields execution of simultaneous tasks hence allowing user interaction with excel which is the whole point of the code.

Jaafar, but the loop after the change includes and DoEvents and Sleep 10. In my opinion, a short break does not limit the user's ability to act. But thanks to it, CPU usage drops from 25% to 4% in my case. And only in this context I propose this change.
Unless you see some negative effects of using Sleep in this code.

Artik

 

[Jaafar Tribak]

Jaafar, but the loop after the change includes and DoEvents and Sleep 10. In my opinion, a short break does not limit the user's ability to act. But thanks to it, CPU usage drops from 25% to 4% in my case. And only in this context I propose this change.
Unless you see some negative effects of using Sleep in this code.

Artik

Hi Artik,

You are absolutly correct. I mistakingly thought you meant using Sleep without DoEvents ... I somehow missed Do: DoEvents: Sleep 10: Loop Until IsWindowVisible(hWnd) = 0& And IsIconic(Application.hWnd) = 0&.

Just gave it a quick test and indeed, CPU usage dropped substantially! Great suggestion not only for this code but for whenever one considers calling DoEvents in longer loops. I will add your suggestion to the linked file demo.

I have used GetQueueStatus and GetInputState in the past to lessen the impact of DoEvents but adding a short Sleep call like you have sugested is easier and seems to work better.

So thank you for this Artik.