AW: mist bekomme es doch nicht hin
12.01.2020 00:10:42
volti
Hallo Thomas,
wie war das mit dem kleinen Finger... ?
Aber Spaß beiseite, anliegend findest Du eine optimierte Version für MsgboxEx für 32- und 64-Bit.
Da die Standard-Messagebox aus Windows verwendet wird, sind hier auch nur drei Buttons vorgesehen, auch wenn hier der code fünf Buttons vorgaukelt.
Möglicherweise sind in der Messagebox tatsächlich fünf Buttons vorhanden, die sich ggf. gegenseitig überlagern, aber das entzieht sich meiner Kenntnis.
Um diese evtl. sichtbar zu machen, bedarf es umfangreichen weiteren Codes, Resizing der Messagebox an sich und weiteres mehr. Das erscheint mir des Aufwandes wegen nicht angemessen.
Also Fazit: Fünf Buttons geht nicht.
Hallo Thomas,
wie war das mit dem kleinen Finger... ?
Aber Spass beiseite, anliegend findest Du eine optimierte Version für MsgboxEx für 32- und 64-Bit.
Da die Standard-Messagebox aus Windows verwendet wird, sind hier auch nur drei Buttons vorgesehen, auch wenn hier der code fünf Buttons vorgaukelt.
Möglicherweise sind in der Messagebox tatsächlich fünf Buttons vorhanden, die sich ggf. gegenseitig überlagern, aber das entzieht sich meiner Kenntnis.
Um diese evtl. sichtbar zu machen, bedarf es umfangreichen weiteren Codes, Resizing der Messagebox an sich und weiteres mehr. Das erscheint mir des Aufwandes wegen nicht angemessen.
Also Fazit: Fünf Buttons geht nicht.
'Userdefined MsgBox 11.01.2020 by KHV
Option Explicit
#If VBA7 Then
Private Declare PtrSafe Function SetWindowPos Lib "user32" (ByVal hwnd As LongPtr, _
ByVal hWndInsertAfter As LongPtr, ByVal x As Long, ByVal y As Long, _
ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Private Declare PtrSafe Function SetDlgItemText Lib "user32" Alias "SetDlgItemTextA" ( _
ByVal hDlg As LongPtr, ByVal nIDDlgItem As Long, ByVal lpString As String) As Long
Private Declare PtrSafe Function GetCurrentThreadId Lib "kernel32" () As Long
Private Declare PtrSafe Function GetDesktopWindow Lib "user32" () As LongPtr
Private Declare PtrSafe Function MessageBox Lib "user32" Alias "MessageBoxA" ( _
ByVal hwnd As LongPtr, ByVal lpText As String, ByVal lpCaption As String, _
ByVal wType As Long) As Long
Private Declare PtrSafe Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" ( _
ByVal idHook As Long, ByVal lpfn As LongPtr, ByVal hmod As LongPtr, _
ByVal dwThreadId As Long) As LongPtr
Private Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" ( _
ByVal hhk As LongPtr) As Long
Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongPtrA" ( _
ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr
Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare PtrSafe Function GetWindowRect Lib "user32" ( _
ByVal hwnd As LongPtr, lpRect As RECT) As Long
Private Declare PtrSafe Function GetSystemMetrics Lib "user32" ( _
ByVal nIndex As Long) As Long
Type MSGBOX_STRUCT
hHook As LongPtr
hwndOwner As LongPtr
vbBtnStyle As Integer
vbDlgStyle As Long
x As Long
y As Long
sBtns() As String
End Type
#Else
Private Declare Function SetWindowPos Lib "user32" (ByVal hWnd As Long, _
ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, _
ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
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 GetCurrentThreadId Lib "kernel32" () As Long
Private Declare Function GetDesktopWindow Lib "user32" () 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 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 hhk 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 GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Function GetSystemMetrics Lib "user32" ( _
ByVal nIndex As Long) As Long
Private Declare Function GetWindowRect Lib "user32" ( _
ByVal hwnd As Long, lpRect As RECT) As Long
Type MSGBOX_STRUCT
hHook As Long
hwndOwner As Long
vbBtnStyle As Integer
vbDlgStyle As Long
x As Long
y As Long
sBtns() As String
End Type
#End If
Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Type POINTAPI
x As Long
y As Long
End Type
Private Const SM_CXSCREEN = 0
Private Const SM_CYSCREEN = 1
Private Const HWND_TOPMOST = -1
Dim tMsg As MSGBOX_STRUCT
#If VBA7 Then
Function MsgBoxHookProc(ByVal uMsg As Long, ByVal wParam As LongPtr, ByVal lParam As Long) As LongPtr
#Else
Function MsgBoxHookProc(ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
#End If
Dim tRect As RECT, lPos As Long
'Funktion versieht die Buttons mit neuen Texten
'Je nach Anzahl gewünschter Buttons wird eine MsgBox mit passendem Style aufgemacht
'Schalter: vbMsgBoxSetForeground, vbSystemModal, vbMsgBoxHelpButton, vbDefaultButton1,2,3,4
If uMsg = 5 Then
With tMsg
If .vbDlgStyle >= vbMsgBoxSetForeground Then _
SetWindowPos wParam, HWND_TOPMOST, 0, 0, 0, 0, &H3 '&H3=SWP_NOMOVE Or SWP_NOSIZE
SetDlgItemText wParam, 1, .sBtns(0)
SetDlgItemText wParam, 2, .sBtns(1)
SetDlgItemText wParam, 3, .sBtns(0)
SetDlgItemText wParam, 4, .sBtns(1)
SetDlgItemText wParam, 5, .sBtns(2)
If .x > 0 And .y > 0 Then
GetWindowRect wParam, tRect
lPos = GetSystemMetrics(SM_CXSCREEN) - (tRect.Right - tRect.Left)
If .x > lPos Then .x = lPos
lPos = GetSystemMetrics(SM_CYSCREEN) - (tRect.Bottom - tRect.Top)
If .y > lPos Then .y = lPos
SetWindowPos wParam, 0, .x, .y, 0, 0, &H1 '&H1=SWP_NOSIZE
End If
UnhookWindowsHookEx .hHook
End With
End If
MsgBoxHookProc = False
End Function
Public Function MsgBoxEx(MsgTxt As String, sTitle As String, _
Optional sButtons As String = "OK", _
Optional vbIcon As Long, Optional bParent As Boolean, _
Optional ByVal x As Long, Optional ByVal y As Long) As String
'Funktion gibt den Text zum gedrückten Button zurück
With tMsg
.x = x: .y = y
If sButtons = "" Then
Select Case (vbIcon And &H7)
Case 0: sButtons = "&Ok"
Case 1: sButtons = "&Ok,A&bbrechen"
Case 2: sButtons = "A&bbrechen,&Wiederholen,&Ignorieren"
Case 3: sButtons = "&Ja,&Nein,A&bbrechen"
Case 4: sButtons = "&Ja,&Nein"
Case 5: sButtons = "&Wiederholen,A&bbrechen"
End Select
End If
.sBtns = Split(sButtons & ",,", ",")
.vbDlgStyle = (vbIcon And &HFFFF8)
.vbBtnStyle = UBound(.sBtns()) - 2
If bParent Then
.hwndOwner = GetDesktopWindow() 'MsgBox unabhängig von Excel
Else
.hwndOwner = Application.hwnd 'MsgBox an Excel gebunden
End If
.hHook = SetWindowsHookEx(5, AddressOf MsgBoxHookProc, _
GetWindowLong(Application.hwnd, -6), GetCurrentThreadId())
Select Case MessageBox(.hwndOwner, Replace(MsgTxt, "¶", vbLf), sTitle, .vbBtnStyle Or .vbDlgStyle)
Case vbOK, vbYes, vbAbort: x = 0
Case vbNo, vbRetry, vbCancel: x = 1
Case vbIgnore: x = 2
End Select
MsgBoxEx = Replace(.sBtns(x), "&", "")
End With
End Function
'Diese Sub's sind zum Testen
'Es können 1,2 oder 3 Buttons angezeigt werden => kommagetrennt angeben
'Wenn keine angegeben sind, werdne die Originaltext (deutsch) laut Style-Vorgabe verwendet
'& vor einem Buchstaben stellt die Shortcuttaste dar z.B. Alt-S usw.
'¶ stellt einen Zeilenumbruch dar (vbLf)
'Die beiden letzten optionalen Parameter sind für die Positionierung der MsgBox
'Zurückgegeben wird keine Nummer, sondern der Buttontext des geklickten Buttons
Sub MeinMsgBoxTest1()
Dim pt As POINTAPI
GetCursorPos pt
MsgBox MsgBoxEx("Habe die Datei nicht gefunden,¶Mail trotzdem absenden?", "Mailversand", _
"&Senden,Er&neut,A&bbrechen", vbCritical Or vbMsgBoxSetForeground, True, pt.x, pt.y)
End Sub
Sub MeinMsgBoxTest2()
Select Case MsgBoxEx("Bitte wähle eine Option aus!", "Auswahl", _
"Option &1,Option &2,Option &3", vbQuestion)
Case "Option 1": MsgBox "Option 1 gewählt"
Case "Option 2": MsgBox "Option 2 gewählt"
Case "Option 3": MsgBox "Option 3 gewählt"
End Select
End Sub
Sub MeinMsgBoxTest3()
MsgBox MsgBoxEx("Hello World!", "MeineMsgbox")
End Sub
viele Grüße
Karl-Heinz