[Cc][+][-]
Option Explicit
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 GetWindowLongPtr 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 Long
vbDlgStyle As Long
x As Long
y As Long
sBtns() As String
End Type
Dim tMsg As MSGBOX_STRUCT
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 GWL_HINSTANCE = (-6)
Private Const GWL_STYLE = (-16)
Private Const SM_CXSCREEN = 0
Private Const SM_CYSCREEN = 1
Private Const HWND_TOPMOST = -1
Function MsgBoxHookProc(ByVal uMsg As Long, ByVal wParam As LongPtr, ByVal lParam As Long) As LongPtr
'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
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
.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, _
GetWindowLongPtr(Application.hwnd, GWL_HINSTANCE), 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), "&", "") 'Shortkey-Zeichen entfernen
End With
End Function
'##### Beispiele #####
'Diese Sub's sind zum Testen
'Es können 1,2 oder 3 Buttons angezeigt werden => kommagetrennt angeben
'Wenn keine angegeben sind, werden die Originaltexte (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 MeinMsgBoxTest()
Select Case MsgBoxEx("Sind Sie sicher, dass Sie die Kablibration von SRV 3starken möchten?!", "Auswahl", _
"&Kalibrieren,S&chließen", vbQuestion)
Case "Kalibrieren": MsgBox "Kalibrieren gewählt"
Case "Schließen": MsgBox "Schließen gewählt"
End Select
End Sub
Sub MeinMsgBoxTest3()
MsgBox MsgBoxEx("Hello World!", "MeineMsgbox")
End Sub
Sub MeinMsgBoxTest4()
MsgBox MsgBoxEx("Hello World,Ich bin jetzt oben links!", "MeineMsgbox", , , , 10, 10)
End Sub