|
Option Explicit
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 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 SendMessage Lib "user32" Alias _
"SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, _
ByVal wParam As Long, lParam As Any) As Long
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 SetWindowLong Lib "user32" Alias _
"SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, _
ByVal dwNewLong As Long) As Long
Private Declare Function UnhookWindowsHookEx Lib "user32" (ByVal _
hHook As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias _
"RtlMoveMemory" (Destination As Any, Source As Any, _
ByVal Length As Long)
Private Type CWPSTRUCT
lParam As Long
wParam As Long
message As Long
hwnd As Long
End Type
Private Const GWL_WNDPROC = (-4)
Private Const WH_CALLWNDPROC = 4
Private Const WM_CTLCOLORBTN = &H135
Private Const WM_CREATE = &H1
Private Const WM_DESTROY = &H2
Private Const WM_SETTEXT = &HC
Private lHook As Long
Private lPrevWnd As Long
Private bCustom As Boolean
Private sButtons() As String
Private lButton As Long
Private sHwnd As String
Public Function MsgBoxEx(ByVal Prompt As String, _
Optional ByVal Buttons As Long = vbOKOnly, _
Optional ByVal Title As String, _
Optional ByVal HelpFile As String, _
Optional ByVal Context As Long, _
Optional ByRef CustomButtons As Variant) As Long
Dim RetVal As Long
bCustom = (Buttons = vbCustom)
If bCustom And IsMissing(CustomButtons) Then
MsgBox "Bei einer benutzerdefinierten MsgBox muss der " & _
"Schaltflächen-Text im Argument 'CustomButtons' " & _
"vorgegeben werden.", vbExclamation, "Fehler"
Exit Function
End If
lHook = SetWindowsHookEx(WH_CALLWNDPROC, AddressOf HookWindow, _
App.hInstance, App.ThreadID)
If Len(Title) = 0 Then Title = App.Title
If bCustom Then
If TypeName(CustomButtons) = "String" Then
ReDim sButtons(0)
sButtons(0) = CustomButtons
Buttons = 0
Else
sButtons = CustomButtons
Buttons = UBound(sButtons)
End If
End If
lButton = 0
RetVal = MsgBox(Prompt, Buttons, Title, HelpFile, Context)
UnhookWindowsHookEx lHook
If bCustom Then RetVal = RetVal - (UBound(CustomButtons) + 1)
bCustom = False
MsgBoxEx = RetVal
End Function
Public Function SubMsgBox(ByVal hwnd As Long, ByVal Msg As Long, _
ByVal wParam As Long, ByVal lParam As Long) As Long
Dim sText As String
Select Case Msg
Case WM_CTLCOLORBTN
SubMsgBox = CallWindowProc( _
lPrevWnd, hwnd, Msg, wParam, ByVal lParam)
If Not bCustom Then Exit Function
If lButton = 0 Then sHwnd = ""
If InStr(sHwnd, " " & Trim(Str(lParam)) & " ") Then
Exit Function
End If
sText = sButtons(lButton)
sHwnd = sHwnd & " " & Trim(Str(lParam)) & " "
lButton = lButton + 1
SendMessage lParam, WM_SETTEXT, Len(sText), ByVal sText
Exit Function
Case WM_DESTROY
SetWindowLong hwnd, GWL_WNDPROC, lPrevWnd
End Select
SubMsgBox = CallWindowProc( _
lPrevWnd, hwnd, Msg, wParam, ByVal lParam)
End Function
Private Function HookWindow(ByVal nCode As Long, _
ByVal wParam As Long, ByVal lParam As Long) As Long
Dim tCWP As CWPSTRUCT
Dim sClass As String
CopyMemory tCWP, ByVal lParam, Len(tCWP)
If tCWP.message = WM_CREATE Then
sClass = Space(255)
sClass = _
Left(sClass, GetClassName(tCWP.hwnd, ByVal sClass, 255))
If sClass = "#32770" Then
lPrevWnd = SetWindowLong(tCWP.hwnd, GWL_WNDPROC, _
AddressOf SubMsgBox)
End If
End If
HookWindow = CallNextHookEx(lHook, nCode, wParam, ByVal lParam)
End Function
|
|