Ever imagined the possibility of making a standard MsgBox MODELESS !!!

[Jaafar Tribak]

Greetings all,

AFAIK, even the API MsgBoxes have no flags to set them to modeless and it could be very convinient to have a standard Modeless MsgBox on display let's say while a some lengthy code is running in the background plus being able to interact with the worksheet while the little msgbox is there on the screen showing you the progress of the background macro.

I know this can be easily achieved via a modeless UserForm made to stay always on top but i like the challenge to make this possible with a standard Msgbox


I am experimenting with some code at the moment that seems promising. Will keep you posted.

Regards.

 

[Weaver]

I've had problems getting modeless userforms to update when there's code running in the background. What's your solution?

 

[Colin Legg]

Hi Weaver,

I've had problems getting modeless userforms to update when there's code running in the background. What's your solution?

Have you tried repainting it?

eg.

 UserForm1.repaint

 

[Charlize]

Private Declare Function APIMsgBox _
    Lib "User32" Alias "MessageBoxA" _
       (Optional ByVal hWnd As Long, _
        Optional ByVal prompt As String, _
        Optional ByVal title As String, _
        Optional ByVal buttons As Long) _
    As Long

Sub test_modeless_msgbox()
Dim response As Long
response = APIMsgBox(prompt:="Select the cell you want ...", buttons:=vbYesNo)
If response = vbYes Then
    MsgBox "You selected : " & ActiveCell.Address & vbCrLf & _
           "Nothing can be done until clicked.", vbInformation
End If
End Sub

Charlize

 

[mikerickson]

If I had to have a modeless MsgBox on my Mac (modless UF's not supported), I'd use Shapes.

 

[Jaafar Tribak]

Greetings all,

Download workbook demo

I came accross this handy DS_NOIDLEMSG dialog Style that can be set during the creation of modal dialogs to make them kind of modeless.

But we are not creating a dialg from scracth here so to apply this to a sandard VBA MsgBox, we need to find a way to catch the MsgBox before it's actually created. To achieve that we need to install a system hook and trap the HCBT_CREATEWND CBT flag.

Once the DS_NOIDLEMSG Style is set for our MsgBox and we have uninstalled the system hook, we need to subclass the MsgBox owner window :ie the Excel Application itself in order to intercept the WM_ENTERIDLE message which is where the asynchronious background code is to be executed.

Finally, the MsgBox itself needs to be subclassed to intercept the WM_NCDESTROY message for the last cleanup when the MsgBox is closed.

Anyway, here is the main code that goes in a Standard module :

[COLOR=seagreen]'**************************************************[/COLOR]
[COLOR=seagreen]'// Code that makes a standard VBA MsgBox Modeless[/COLOR]
[COLOR=seagreen]'// enablig code to run asynchronously and the user[/COLOR]
[COLOR=seagreen]'// interaction with the worksheet.[/COLOR]
[COLOR=seagreen]'**************************************************[/COLOR]
Option Explicit
 
Private 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
 
Private Declare Function UnhookWindowsHookEx Lib "user32" _
(ByVal hHook As Long) As Long
 
Private Declare Function CallNextHookEx Lib "user32" _
(ByVal hHook As Long, _
ByVal ncode As Long, _
ByVal WParam As Long, _
lparam As Any) As Long
Private Declare Function GetCurrentThreadId Lib "kernel32" _
() As Long
 
Private Declare Function SetWindowLong Lib "user32" _
Alias "SetWindowLongA" _
(ByVal hwnd As Long, _
ByVal nIndex As Long, _
ByVal dwNewLong As Long) As Long
 
Private Declare Function CallWindowProc Lib "user32" _
Alias "CallWindowProcA" _
(ByVal lpPrevWndFunc As Long, _
ByVal hwnd As Long, _
ByVal MSG As Long, _
ByVal WParam As Long, _
ByVal lparam As Long) As Long
 
Private Declare Function GetClassName Lib "user32" _
Alias "GetClassNameA" _
(ByVal hwnd As Long, _
ByVal lpClassName As String, _
ByVal nMaxCount As Long) As Long
 
Private Declare Function GetWindowLong Lib "user32" _
Alias "GetWindowLongA" _
(ByVal hwnd As Long, _
ByVal nIndex As Long) As Long
 
Private Declare Function EnableWindow Lib "user32" _
(ByVal hwnd As Long, _
ByVal fEnable As Long) As Long
 
Private Declare Function FindWindow Lib "user32" _
Alias "FindWindowA" _
(ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
 
Private Const WH_CBT As Long = 5
Private Const HCBT_CREATEWND As Long = 3
Private Const GWL_STYLE As Long = -16
Private Const DS_NOIDLEMSG As Long = &H100&
Private Const GWL_WNDPROC As Long = (-4)
Private Const WM_ENTERIDLE As Long = &H121
Private Const WM_COMMAND As Long = &H111
Private Const WM_NCDESTROY As Long = &H82
 
Public lRet As VbMsgBoxResult
 
Private lOldAppWindowProc As Long
Private lOldMsgBxWindowProc As Long
Private lXLAPPhwnd As Long
Private lhHook As Long
Private sAsyncProc As String
Private lMsgBoxhwnd As Long
 
Private Sub CreateHook(AsyncProc As String)
 
    [COLOR=seagreen]'store the asyncProc arg in a module[/COLOR]
[COLOR=seagreen]  'level var for later use.[/COLOR]
    sAsyncProc = AsyncProc
 
    [COLOR=seagreen]'retrieve the excel app hwnd for later use.[/COLOR]
    lXLAPPhwnd = FindWindow("XLMAIN", Application.Caption)
 
    [COLOR=seagreen]'install a system hook to catch[/COLOR]
    [COLOR=seagreen]'the creation of the MsgBox.[/COLOR]
    lhHook = SetWindowsHookEx _
    (WH_CBT, AddressOf HookProc, 0, GetCurrentThreadId)
 
End Sub
 
Private Function HookProc _
(ByVal idHook As Long, ByVal WParam As Long, _
ByVal lparam As Long) As Long
 
    Dim strBuffer As String
    Dim lRetVal As Long
    Dim lCurrentStyle As Long
    Dim lNewStyle As Long
 
    [COLOR=seagreen]'a wnd is being created.[/COLOR]
    If idHook = HCBT_CREATEWND Then
        strBuffer = Space(256)
 
        [COLOR=seagreen]'check if the wnd is our MsgBox.[/COLOR]
        lRetVal = GetClassName(WParam, strBuffer, 256)
        If Left(strBuffer, lRetVal) = "#32770" Then
 
            [COLOR=seagreen]'if so,store its hwnd in a module[/COLOR]
[COLOR=seagreen]          'level var for later use.[/COLOR]
            lMsgBoxhwnd = WParam
 
           [COLOR=seagreen]'now, let's set the msgbox DS_NOIDLEMSG[/COLOR]
[COLOR=seagreen]          'style to make it modeless.[/COLOR]
            lCurrentStyle = GetWindowLong(WParam, GWL_STYLE)
            lNewStyle = lCurrentStyle And Not DS_NOIDLEMSG
            SetWindowLong WParam, GWL_STYLE, lNewStyle
 
            [COLOR=seagreen]'we now need to subclass the excel app[/COLOR]
[COLOR=seagreen]          'to catch the WM_ENTERIDLE message and[/COLOR]
[COLOR=seagreen]          'make the running of an async macro possible.[/COLOR]
            Call SubClassApp(lXLAPPhwnd)
 
            [COLOR=seagreen]'subclass the msgbox to catch the[/COLOR]
[COLOR=seagreen]          'WM_NCDESTROY message necessary to[/COLOR]
[COLOR=seagreen]          'cleanup and set the lRet var.[/COLOR]
            Call SubClassMsgBx(WParam)
 
            [COLOR=seagreen]'we don't need the hook anymore.[/COLOR]
            UnhookWindowsHookEx lhHook
        End If
    End If
 
    [COLOR=seagreen]'Call next hook[/COLOR]
    HookProc = CallNextHookEx _
    (lhHook, idHook, ByVal WParam, ByVal lparam)
 
End Function
 
Private Sub SubClassApp(hwnd As Long)
 
    [COLOR=seagreen]'subclass the excel app here.[/COLOR]
    lOldAppWindowProc = _
    SetWindowLong(hwnd, GWL_WNDPROC, AddressOf NewAppWindowProc)
 
End Sub
 
Private Sub UnSubClassApp(hwnd As Long)
 
    [COLOR=seagreen]'UnSubClassApp The Excel Application here.[/COLOR]
    SetWindowLong hwnd, GWL_WNDPROC, lOldAppWindowProc
 
End Sub
 
Private Function NewAppWindowProc(ByVal hwnd As Long, ByVal MSG _
As Long, ByVal WParam As Long, ByVal lparam As Long) As _
Long
 
    On Error Resume Next
 
    Select Case MSG
 
        Case WM_ENTERIDLE
 
        [COLOR=seagreen]'is our msgbox being created[/COLOR]
[COLOR=seagreen]      'within the excel app ?[/COLOR]
[COLOR=seagreen]      'if so, enable back the main xl[/COLOR]
[COLOR=seagreen]      'window and run our async macro.[/COLOR]
        EnableWindow hwnd, 1
        Application.Run ThisWorkbook.Name & "!" & sAsyncProc
 
       [COLOR=seagreen]'we are done with the subclassing of excel.[/COLOR]
        Call UnSubClassApp(hwnd)
 
    End Select
 
    [COLOR=seagreen]' Pass Intercepted Messages To The Original WinProc[/COLOR]
    NewAppWindowProc = _
    CallWindowProc(lOldAppWindowProc, hwnd, MSG, WParam, lparam)
 
End Function
 
Private Sub SubClassMsgBx(hwnd As Long)
 
    [COLOR=seagreen]'reset the msgbox lRet and subclass our msgbox here.[/COLOR]
    lRet = 0
    lOldMsgBxWindowProc = _
    SetWindowLong(hwnd, GWL_WNDPROC, AddressOf NewMsgBxWindowProc)
 
End Sub
 
Private Sub UnSubClassMsgBx(hwnd As Long)
 
    [COLOR=seagreen]'UnSubClassApp our msgbox here.[/COLOR]
    SetWindowLong hwnd, GWL_WNDPROC, lOldMsgBxWindowProc
 
End Sub
 
Private Function NewMsgBxWindowProc(ByVal hwnd As Long, ByVal MSG _
As Long, ByVal WParam As Long, ByVal lparam As Long) As _
Long
 
    On Error Resume Next
 
    Select Case MSG
 
    [COLOR=seagreen]'unsubclass our msgbox upon[/COLOR]
[COLOR=seagreen]  'closing it and set the lRet var[/COLOR]
[COLOR=seagreen]  'to exit the async macro.[/COLOR]
    Case WM_NCDESTROY, WM_COMMAND
        UnSubClassMsgBx hwnd
        lRet = vbOK
    End Select
 
    [COLOR=seagreen]' Pass Intercepted Messages To The Original WinProc[/COLOR]
    NewMsgBxWindowProc = _
    CallWindowProc(lOldMsgBxWindowProc, hwnd, MSG, WParam, lparam)
 
End Function
 
[COLOR=seagreen]'here is the modeless msgbox function signature[/COLOR]
[COLOR=seagreen]'which is basically a wrapper for a standard msgbox.[/COLOR]
Public Function ModelessMsgBox _
(Prompt As String, _
AsyncProcName As String, _
Optional Flags As VbMsgBoxStyle, _
Optional Title As String, _
Optional HelpFile As String, _
Optional Context As Long) As VbMsgBoxResult
 
    Call CreateHook(AsyncProcName)
    ModelessMsgBox = MsgBox(Prompt, Flags, Title, HelpFile, Context)
 
End Function

And here is a test showing how we can call the modeless msgbox ( in a standard module) - Run the Test routine.

Option Explicit
 
[COLOR=seagreen]'Pass the "MyAsyncProcedure" procedure as the[/COLOR]
[COLOR=seagreen]'second argument of the ModelessMsgBox function.[/COLOR]
 
Sub test()
 
    lRet = ModelessMsgBox( _
        Prompt:="Like to cancel Background Macro ?", _
        AsyncProcName:="MyAsyncProcedure", _
        Flags:=vbSystemModal + vbQuestion, _
        Title:="Modeless Msgbox test.")
 
End Sub
 
Private Sub MyAsyncProcedure()
 
    [COLOR=seagreen]'macro that simply increments the Cell B4 by 1[/COLOR]
[COLOR=seagreen]  'as well as the statusbar to illustrate that[/COLOR]
[COLOR=seagreen]  'code can run while a standard msgbox is on[/COLOR]
[COLOR=seagreen]  'display !![/COLOR]
 
    On Error Resume Next
 
    Application.StatusBar = 1
    Range("b4").ClearContents
 
    Do
        Range("b4") = Range("b4") + 1
        Application.StatusBar = Application.StatusBar + 1
        DoEvents
    Loop Until lRet = vbOK
 
    Application.StatusBar = False
    MsgBox "You Canceled.", vbInformation
 
End Sub

I wrote the ModelessMsgBox function arguments in the same order as that of the standard VBA msgbox except for the second argument which is passed the name of the background async macro as a String.

Note that the async code must be located in a different routine and not immediatly after the ModelessMsgBox function call.

Tested on WIN XP SP3 excel 2003 . I just hope it works for other versions too.

Regards.