[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]
