MsgBox that waits for user input

Jaafar Tribak

Jaafar Tribak

Well-known Member
Joined
Dec 5, 2002
Messages
9,656
Office Version
  1. 2016
Platform
  1. Windows
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 :
VBA 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:
VBA Code: 
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:
VBA Code: 
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.
 

Excel Facts

Using Function Arguments with nested formulas
If writing INDEX in Func. Arguments, type MATCH(. Use the mouse to click inside MATCH in the formula bar. Dialog switches to MATCH.
Sort by date Sort by votes
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
 
Upvote 0
Joe4 said:
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
Click to expand...
No problem. Thanks for letting me know.
 
Upvote 0
@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.
 
Upvote 0
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:
VBA Code: 
#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:
VBA Code: 
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. (y)

Artik
 
Upvote 0

@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.
 
Last edited:
Upvote 0
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.
Click to expand...
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
 
Upvote 0
Artik said:
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
Click to expand...
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.
 
Upvote 0
You must log in or register to reply here.

Similar threads

Jaafar Tribak
  • Question
Custom Accessibility Class
Replies
4
Views
579
Jaafar Tribak
Jaafar Tribak
Jaafar Tribak
  • Question
VBA MsgBox customized to display data in tabular format _ (Data arranged in straight rows and columns)
Replies
5
Views
1K
Jaafar Tribak
Jaafar Tribak
Jaafar Tribak
  • Question
ScreenTips For Shapes and Buttons.
2
Replies
10
Views
2K
6diegodiego9
6
Jaafar Tribak
  • Question
DLL Export Viewer ( VBA Based )
Replies
6
Views
1K
Jaafar Tribak
Jaafar Tribak
M
  • Question
Problem with VBA Code in Libre
Replies
0
Views
549
microhunt
M

Forum statistics

Threads
1,216,499
Messages
6,131,012
Members
449,613
Latest member
MedDash99

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top