Wscript PopUp make application modal in MS Access 2

[patriciaxxx]

I have posted this in Access modules forum because that’s the application I’m using it in and also the one that I cant get it to be modal in I have tried every variation of vbApplicationModal and numbers I can think of.

Does anyone know how to make the code that runs the PopUp “application modal” in MS Access 2003

'This requires a reference to the Windows Script Host Object Model
Public Sub MessageTest()
Dim SH As IWshRuntimeLibrary.WshShell
Dim Res As Long

Set SH = New IWshRuntimeLibrary.WshShell
Res = SH.PopUp(Text:="Click Me", secondstowait:=2, _
Title:="Hello, World", Type:=vbOKOnly)

End Sub

 

[strongm]

Ok, beginning to look like GetDlgItem under W7 is the culprit ...

 

[strongm]

Yep, that'll teach me to make assumptions ... definitely a problem with GetDlgItem - specifically hwndMsgBox is not being set correctly during the hooking procedure, and so GetDlgItem fails becasue it is looking for a control in the wrong window.

A minor modification of Function WinProc fixes the issue. I'll repost all of the module, since there is also an additional declare Basically yu can replace the first module given above with this module:

[blue]Option Compare Database
Option Explicit

' Necessary constants  for hooking
Private Const HCBT_ACTIVATE = 5
Private Const WH_CBT = 5

' Possibly overkill for this example
Private Type CUSTOM_MSGBOX
    lTimeout As Long
    lExitButton As Long
End Type

Public cm As CUSTOM_MSGBOX

' Working variables that require global scope in hooking module
Private hHook As Long
Public hwndMsgBox As Long
Public lTimerHandle As Long
Public hAppInstance As Long

' The API declarations we need
Public Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExW" (ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, ByVal dwThreadId As Long) As Long
Public Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
[b]Private Declare Function GetCurrentThreadId Lib "kernel32" () As Long
Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long[/b]
Public Const GWL_HINSTANCE = (-6)

'Windows-defined MessageBox return values
Public Enum ExitButton
    IDOK = 1
    IDCANCEL = 2
    IDABORT = 3
    IDRETRY = 4
    IDIGNORE = 5
    IDYES = 6
    IDNO = 7
End Enum

' Our wrapper for the normal MsgBox function
Public Function vbTimedMsgBox(Prompt As String, Optional Buttons As VbMsgBoxStyle = vbOKOnly, Optional Title As String, Optional HelpFile As String, Optional Context As Long, Optional TimeOut As Long = 0, Optional DefaultExitButton As ExitButton = IDOK) As Long
    cm.lTimeout = TimeOut
    cm.lExitButton = DefaultExitButton
    hAppInstance = GetWindowLong(hWndAccessApp, GWL_HINSTANCE) ' Access specific. In VB, this would be App.hInstance
    hHook = SetWindowsHookEx(WH_CBT, AddressOf WinProc, hAppInstance, [b]GetCurrentThreadId[/b])
    vbTimedMsgBox = MsgBox(Prompt, Buttons, Title, HelpFile, Context)
End Function

Private Function WinProc(ByVal lMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Dim hwndCaption As Long
    Dim CurrentStyle As Long
    Dim ClassName As String
    [b]Dim lResult as long[/b]
    
    If lMsg = HCBT_ACTIVATE Then
        [b]ClassName = Space(256)
        lResult = GetClassName(wParam, ClassName, 256)
        If Left(ClassName, lResult) = "#32770" Then[/b] ' Make sure we spotted a messagebox (dialog)
            hwndMsgBox = wParam
            If cm.lTimeout Then lTimerHandle = SetTimer(0&, 0&, cm.lTimeout, AddressOf TimerHandler)
            UnhookWindowsHookEx hHook
        [b]End If[/b]
    End If

    WinProc = False
End Function[/blue]

This should now work for all versions of Access on all versions of Windows.

 

[patriciaxxx]

I'm using Access 2002 on windows XP.

Strongm your minor modification did the trick, it now works for me too, thank you.

Ben your example I can’t get to work, is it for VB6 or is it because I’m using Access 2002.

Thanks again to the experts.

 

[patriciaxxx]

Hello strongm

Does your Timer module allow for a display of the countdown of the time in the message box i.e your usage example would display the countdown from 5 through to 0 in the MsgBox along with any message, buttons etc.

 

[strongm]

Not as it stands, no. It only gets one event, which closes the dialog.

But that doesn't stop us ... again, some minor modification, this time to both modules. So, module1:

[blue]Option Compare Database
Option Explicit

' Necessary constants  for hooking
Private Const HCBT_ACTIVATE = 5
Private Const WH_CBT = 5

' Possibly overkill for this example
Private Type CUSTOM_MSGBOX
    lTimeout As Long
    lExitButton As Long
    lInterval As Long
    strPrompt As String
End Type

Public cm As CUSTOM_MSGBOX

' Working variables that require global scope in hooking module
Private hHook As Long
Public hwndMsgBox As Long
Public lTimerHandle As Long
Public hAppInstance As Long

' The API declarations we need
Public Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExW" (ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, ByVal dwThreadId As Long) As Long
Public Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Declare Function GetCurrentThreadId Lib "kernel32" () As Long
Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Public Const GWL_HINSTANCE = (-6)

'Windows-defined MessageBox return values
Public Enum ExitButton
    IDOK = 1
    IDCANCEL = 2
    IDABORT = 3
    IDRETRY = 4
    IDIGNORE = 5
    IDYES = 6
    IDNO = 7
End Enum


' Our wrapper for the normal MsgBox function
Public Function vbTimedMsgBox(Prompt As String, Optional Buttons As VbMsgBoxStyle = vbOKOnly, Optional Title As String, Optional HelpFile As String, Optional Context As Long, Optional Timeout As Long = 0, Optional Tick As Long = 1000, Optional DefaultExitButton As ExitButton = IDOK) As Long
    cm.lTimeout = Timeout
    cm.lExitButton = DefaultExitButton
    cm.strPrompt = Prompt
    cm.lInterval = Tick

    hAppInstance = GetWindowLong(hWndAccessApp, GWL_HINSTANCE) ' Access specific. In VB, this would be App.hInstance
    hHook = SetWindowsHookEx(WH_CBT, AddressOf WinProc, hAppInstance, GetCurrentThreadId)
    vbTimedMsgBox = MsgBox(Replace(Prompt, "%T", CStr(Timeout / 1000)), Buttons, Title, HelpFile, Context)
    KillTimer 0&, lTimerHandle
End Function

Private Function WinProc(ByVal lMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Dim hwndCaption As Long
    Dim CurrentStyle As Long
    Dim ClassName As String
    Dim lResult As Long
    Dim Timeout As Long
    
    If lMsg = HCBT_ACTIVATE Then
        ClassName = Space(256)
        lResult = GetClassName(wParam, ClassName, 256)
        If Left(ClassName, lResult) = "#32770" Then ' Make sure we spotted a messagebox (dialog)
            hwndMsgBox = wParam
            Timeout = cm.lInterval
            If Timeout = 0 Then Timeout = cm.lTimeout
            If cm.lTimeout Then lTimerHandle = SetTimer(0&, 0&, Timeout, AddressOf TimerHandler)
            UnhookWindowsHookEx hHook
        End If
    End If

    WinProc = False
End Function[/blue]

And module 2

[blue]Option Compare Database
Option Explicit

Public Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Public Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
Private Declare Function SetFocus Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetDlgItem Lib "user32" (ByVal hDlg As Long, ByVal nIDDlgItem As Long) As Long
Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Public Declare Function SetDlgItemText Lib "user32" Alias "SetDlgItemTextA" (ByVal hDlg As Long, ByVal nIDDlgItem As Long, ByVal lpString As String) As Long

Private Const WM_LBUTTONDOWN = &H201
Private Const WM_LBUTTONUP = &H202
Public Const IDPROMPT = &HFFFF&


Public Sub TimerHandler(hwnd As Long, uMSG As Integer, idEvent As Integer, dwTime As Double)
    Dim hWndTargetBtn As Long
     
    cm.lTimeout = cm.lTimeout - cm.lInterval ' being a bit cheap here - as a result don't expect particualrly accurate timing
    
    SetDlgItemText hwndMsgBox, IDPROMPT, Replace(cm.strPrompt, "%T", CStr(cm.lTimeout / 1000))
    
    If cm.lTimeout <= 0 Then
        hWndTargetBtn = GetDlgItem(hwndMsgBox, cm.lExitButton)
             
        ' set the focus to the target button and
        ' simulate a click to close the dialog and
        ' return the correct value
        If hWndTargetBtn <> 0 Then
            SetFocus hWndTargetBtn
            DoEvents
            Call PostMessage(hWndTargetBtn, WM_LBUTTONDOWN, 0, ByVal 0&)
            Call PostMessage(hWndTargetBtn, WM_LBUTTONUP, 0, ByVal 0&)
        End If
     End If
End Sub[/blue]

And can be called

Result = vbTimedMsgBox("Closing in %T seconds", vbOKCancel, , , , 5000, 1000, IDCANCEL)

where %T will be replaced by the remaining time in the MsgBox

 

[patriciaxxx]

Strongm this looks great

I tried it but the code fails to compile for me where highlighted below with the following compile error “Expected variable or procedure not module”:

' Our wrapper for the normal MsgBox function
Public Function vbTimedMsgBox(Prompt As String, Optional Buttons As VbMsgBoxStyle = vbOKOnly, Optional Title As String, Optional HelpFile As String, Optional Context As Long, Optional Timeout As Long = 0, Optional Tick As Long = 1000, Optional DefaultExitButton As ExitButton = IDOK) As Long
cm.lTimeout = Timeout
cm.lExitButton = DefaultExitButton
cm.strPrompt = Prompt
cm.lInterval = Tick

hAppInstance = GetWindowLong(hWndAccessApp, GWL_HINSTANCE) ' Access specific. In VB, this would be App.hInstance
hHook = SetWindowsHookEx(WH_CBT, AddressOf WinProc, hAppInstance, GetCurrentThreadId)
vbTimedMsgBox = [highlight #FCE94F]msgbox[/highlight](Replace(Prompt, "%T", CStr(Timeout / 1000)), Buttons, Title, HelpFile, Context)
KillTimer 0&, lTimerHandle
End Function

 

[patriciaxxx]

Hello Strongm

That was my bad, I made a paste error.

The code is excellent and works perfectly.

Thank you for your help, patience and continued interest in this post.

 

[patriciaxxx]

Strongm is it ok to combine the two modules into one just for streamlining.

 

[strongm]

No reason why not. I had certain reasons for keeping them seperate, but feel free to combine them (you can then change each instance of Public to Private, if you like, except for vbTimedMsgBox and Enum ExitButton, to ensure least necessary level of variable scope)