API Schließkreuz MsgBox deaktivieren
21.12.2010 12:04:40
Reinhard
Hallo Holger,
nachfolgenden Code von Andreas Killer fand ich bei
http://www.myunitsconverter.com/thread/2258355/Schlie%C3%9Fen%20einer%20MsgBox
Dort gibt es noch einen Code von Michael Schwimmer, den brachte ich nicht zum Laufen.
Anfangs meldet der Debugger nacheinander 3 Fehler, sind beim Kopieren entstanden.
2mal steht da anstatt AdrressOF xyz halt AdrressOFxyz. Da ein Leerzeichen einzufügen ist ja einfach.
Den dritten Fehler habe ich vergesen, aber auch was einfach findbares, der Debugger zeigt ja die Stelle.
Aber dann kommt der 4te Fehler in der Zeile:
mlngHookMsg = SetWindowsHookEx(WH_CBT, AddressOf MsgBoxHookProc, Application.hInstance, GetCurrentThreadId())
Fehler 438, Objekt unterstützt diese Methode oder Eigenschaft nicht.
Nachfolgend ist der erste Code von Andreas, nach der Sternenreihe der von Michael.
Gruß
Reinhard
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 Declare Function GetCurrentThreadId Lib "kernel32" () _
As Long
Private Declare Function GetModuleHandle Lib "kernel32" Alias _
"GetModuleHandleA" (ByVal lpModuleName As String) 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 sButtons() As String
Private lButton As Long
Private sHwnd As String
Sub Example_MsgBoxEx()
Dim RetVal As Variant
RetVal = MsgBoxEx("Ist diese MessageBox eine Möglichkeit?", _
"Example_MsgBoxEx", vbQuestion + vbDefaultButton2, "Na &ja", _
"&Weniger", "&Nööö")
Select Case RetVal
Case 1: MsgBox "Na ja"
Case 2: MsgBox "Weniger"
Case 3: MsgBox "Nööö"
End Select
End Sub
Public Function MsgBoxEx(ByVal Prompt As String, ByVal Title _
As String, ByVal Options As VbMsgBoxStyle, ParamArray Buttons( _
)) As Integer
Dim I As Integer
Dim lngModHwnd As Long
Dim lngThreadID As Long
If UBound(Buttons)
****************************************************************************************************************************
Option Explicit
Private Declare Function SetDlgItemText _
Lib "user32" Alias "SetDlgItemTextA" ( _
ByVal hDlg As Long, _
ByVal nIDDlgItem As Long, _
ByVal lpString As String _
) As Long
Private Declare Function SendDlgItemMessage _
Lib "user32" Alias "SendDlgItemMessageA" ( _
ByVal hDlg As Long, _
ByVal nIDDlgItem As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long _
) 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 CallNextHookEx _
Lib "user32" ( _
hHook As Long, _
ncode As Long, _
wParam As Long, _
lParam As Long _
) As Long
Private Declare Function UnhookWindowsHookEx _
Lib "user32" ( _
ByVal hHook As Long _
) As Long
Private Declare Function GetCurrentThreadId _
Lib "kernel32" () As Long
Private Declare Function MessageBox _
Lib "user32" Alias "MessageBoxA" ( _
ByVal hwnd As Long, _
ByVal lpText As String, _
ByVal lpCaption As String, _
ByVal wType As Long) As Long
Private Declare Function SetTimer _
Lib "user32" ( _
ByVal hwnd As Long, _
ByVal nIDEvent As Long, _
ByVal uElapse As Long, _
ByVal lpTimerFunc As Long _
) As Long
Private Declare Function KillTimer _
Lib "user32" ( _
ByVal hwnd As Long, _
ByVal nIDEvent 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 PostMessage _
Lib "user32" Alias "PostMessageA" ( _
ByVal hwnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long _
) As Long
Private Declare Function SetForegroundWindow _
Lib "user32" ( _
ByVal hwnd 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 SetWindowLong _
Lib "user32" Alias "SetWindowLongA" ( _
ByVal hwnd As Long, _
ByVal nIndex As Long, _
ByVal dwNewLong As Long _
) As Long
Private Declare Function DrawMenuBar _
Lib "user32" ( _
ByVal hwnd As Long _
) As Long
Private Const WS_MAXIMIZEBOX As Long = &H10000
Private Const WS_MINIMIZEBOX As Long = &H20000
Private Const WS_SYSMENU As Long = &H80000
Private Const WS_THICKFRAME As Long = &H40000
Private Const WS_DLGFRAME As Long = &H400000
Private Const WS_BORDER As Long = &H800000
Private Const GWL_STYLE As Long = (-16)
Private Const SC_CLOSE As Long = &HF060&
Private Const WM_LBUTTONDOWN As Long = &H201
Private Const WM_LBUTTONUP As Long = &H202
Private Const WM_SYSCOMMAND As Long = &H112
Private Const GWL_lngInstance As Long = (-6)
Private Const WH_CBT As Long = 5
Private Const HCBT_ACTIVATE As Long = 5
Private Const HC_ACTION As Long = 0
Private mstrYes As String
Private mstrNo As String
Private mstrOk As String
Private mstrCancel As String
Private mstrAbort As String
Private mstrRetry As String
Private mstrIgnore As String
Private mblnWithoutX As Boolean
Private mlngButton As Long
Private mlngTimerMsg As Long
Private mlngHookMsg As Long
Private mlngHandleMsg As Long
Public Sub TestApiMsgBox()
' Kaufmännisches UND Zeichen vor einem Button-Buchstaben stellt
' diesen unterstrichen dar, als Kennzeichen für einen Shortcut
Select Case MessageBoxXL( _
strPrompt:="Prompt", _
lngButtons:=vbYesNoCancel Or _
vbDefaultButton1 Or _
vbQuestion, _
strTitle:="Title", _
TextYes:="&Joo", _
TextNo:="N&ee", _
TextCancel:="Ni&x machen", _
TimeoutButtonID:=vbYes, _
TimeoutSec:=10, _
IsModeless:=False, _
WithoutX:=True)
Case vbYes
MsgBox "Ja"
Case vbNo
MsgBox "Nein"
Case vbCancel
MsgBox "Abbrechen"
End Select
End Sub
Public Function MessageBoxXL( _
strPrompt As String, _
Optional lngButtons As Long, _
Optional strTitle As String, _
Optional TextYes As String, _
Optional TextNo As String, _
Optional TextOk As String, _
Optional TextCancel As String, _
Optional TextAbort As String, _
Optional TextRetry As String, _
Optional TextIgnore As String, _
Optional TimeoutButtonID As Long, _
Optional TimeoutSec As Long, _
Optional IsModeless As Boolean, _
Optional WithoutX As Boolean) As Long
Dim lngAppHwnd As Long
' Einige modulweite Variablen zurücksetzen
mlngHandleMsg = 0: mlngHookMsg = 0: mlngTimerMsg = 0
' Modulweite Variablen initialisieren
mstrYes = TextYes
mstrNo = TextNo
mstrOk = TextOk
mstrCancel = TextCancel
mstrAbort = TextAbort
mstrRetry = TextRetry
mstrIgnore = TextIgnore
mblnWithoutX = WithoutX
mlngHookMsg = SetWindowsHookEx(WH_CBT, AddressOf MsgBoxHookProc, Application.hInstance, _
GetCurrentThreadId())
If TimeoutSec > 0 Then
TimeoutSec = TimeoutSec * 1000
mlngButton = TimeoutButtonID
' Timer Timeout initialisieren
mlngTimerMsg = SetTimer(0, 0, TimeoutSec, AddressOf TimerProcMsg)
End If
' Wenn Modeless erwünscht, muss lngAppHwnd Null sein
If Not IsModeless Then lngAppHwnd = Application.hwnd
' API-Messagebox aufrufen
MessageBoxXL = MessageBox( _
lngAppHwnd, _
strPrompt, _
strTitle, _
lngButtons)
' Timer löschen
KillTimer 0, mlngTimerMsg
End Function
Public Function MsgBoxHookProc( _
ByVal uMsg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long _
) As Long
Dim strClass As String
Dim lngRet As Long
Dim lngStyle As Long
On Error Resume Next
If uMsg "" Then
SetDlgItemText wParam, vbYes, mstrYes
End If
If mstrNo "" Then
SetDlgItemText wParam, vbNo, mstrNo
End If
If mstrOk "" Then
SetDlgItemText wParam, vbOK, mstrOk
End If
If mstrCancel "" Then
SetDlgItemText wParam, vbCancel, mstrCancel
End If
If mstrNo "" Then
SetDlgItemText wParam, vbAbort, mstrAbort
End If
If mstrOk "" Then
SetDlgItemText wParam, vbRetry, mstrRetry
End If
If mstrCancel "" Then
SetDlgItemText wParam, vbIgnore, mstrIgnore
End If
If mblnWithoutX Then
' Macht nur wirklich Sinn, wenn MsgBox auf
' den Stil vbYesNo oder vbAbortRetryIgnore
' gesetzt ist, da sonst auch ohne das Schließen-X
' immer noch mit Alt/F4 abgebrochen werden kann
' Die Fensterstile ermitteln
lngStyle = GetWindowLong(wParam, GWL_STYLE)
' Stilbit WS_SYSMENU löschen
lngStyle = lngStyle And Not WS_SYSMENU
' Den geänderten Stil setzen
SetWindowLong wParam, GWL_STYLE, lngStyle
' Menübar neu zeichnen
DrawMenuBar wParam
End If
' Hook aufheben
UnhookWindowsHookEx mlngHookMsg
End If
End If
MsgBoxHookProc = CallNextHookEx(mlngHookMsg, uMsg, wParam, lParam)
End Function
Public Function TimerProcMsg( _
ByVal hwnd As Long, _
ByVal Msg As Long, _
ByVal idEvent As Long, _
ByVal dwTime As Long)
' Timer löschen
KillTimer 0, mlngTimerMsg
' Messagebox schließen
MsgboxClose
End Function
Private Sub MsgboxClose()
On Error Resume Next
If mlngHandleMsg = 0 Then Exit Sub
' Messagebox in den Vordergrund (wichtig, wenn modeless)
SetForegroundWindow mlngHandleMsg
If mlngButton 0 Then
' Mausklick auf diesen Button wird simuliert
SendDlgItemMessage mlngHandleMsg, mlngButton, _
WM_LBUTTONDOWN, 0&, 0&
SendDlgItemMessage mlngHandleMsg, mlngButton, _
WM_LBUTTONUP, 0&, 0&
Else
' Fenster ohne Betätigung eines Buttons schließen
' Aber nur, wenn man auch einen Abbrechen-Button
' oder ein entsprechendes Systemmenü hat
PostMessage mlngHandleMsg, WM_SYSCOMMAND, SC_CLOSE, 0
End If
End Sub