Eigene MSGBox - Buttonrückgabe aber wie

volti · 3. Dezember 2024, 17:30

Hallo Rod,

hier der derzeitige Code. Der hatte mal funktioniert. Ist aber VBA.....

Visual Basic-Quellcode

Option Explicit
Private Declare PtrSafe Function GetProcAddress Lib "kernel32" ( _
ByVal hModule As LongPtr, ByVal lpProcName As String) As LongPtr
Private Declare PtrSafe Function LoadLibraryA Lib "kernel32" ( _
ByVal lpLibFileName As String) As LongPtr
Private Declare PtrSafe Function FreeLibrary Lib "kernel32" ( _
ByVal hLibModule As LongPtr) As Long
Private Type MSGBOXPARAMS
cbSize As Long
hWndOwner As LongPtr
hInstance As LongPtr
lpszText As LongPtr
lpszCaption As LongPtr
dwStyle As Long
lpszIcon As LongPtr
dwContextHelpId As Long
lpfnMsgBoxCallback As LongPtr
dwLanguageId As Long
End Type
Private Type MSGBOXDATA
PARAMS As MSGBOXPARAMS
pwndOwner As LongPtr ' Nur intern
dwPadding As Long
wLanguageId As Long
pidButton As LongPtr ' Array (Button-IDs)
ppszButtonText As LongPtr ' Array (Buttontext)
cButtons As Long ' Anzahl der Buttons
defButton As Long ' Button-ID Default
cancelId As Long ' Button-ID Abbruch
Timeout As Long ' Timeout
phwndList As LongPtr ' Nur intern
dwReserved(19) As Long ' Reserviert
End Type
Private Declare PtrSafe Function SoftModalMessageBox Lib "user32" (pMsgBoxParams As MSGBOXDATA) As Long
Function MsgboxEx(ByVal sText As String, _
Optional ByVal sBtns As String = "OK", _
Optional ByVal sCaption As String = "Microsoft Excel", _
Optional ByVal iIcon As Long, _
Optional ByVal iTimeOut As Long, _
Optional ByVal iDefBtn As Long) As String
Dim md As MSGBOXDATA
Dim lArrBtn() As Long, sArrTxt() As String, i As Long
Dim hModul As LongPtr, hRet As LongPtr
hModul = LoadLibraryA("User32.dll") ' Bibliothek laden
If hModul <> 0& Then
hRet = GetProcAddress(hModul, "SoftModalMessageBox") ' Funktion vorhanden?
FreeLibrary hModul ' Bibliothek schließen
End If
If hRet = 0 Then Exit Function ' Anzeige nicht möglich
sArrTxt = Split(sBtns, ",") ' Buttontexte in Array
ReDim lArrBtn(UBound(sArrTxt)) ' ID-Array dimensionieren
For i = 0 To UBound(lArrBtn): lArrBtn(i) = i + 1: Next i ' IDs in Array setzen
With md
With .PARAMS
.cbSize = LenB(md.PARAMS)
.hWndOwner = Application.hwnd ' Excel-Handle
.hInstance = Application.HinstancePtr ' Excel-Instance
.lpszText = StrPtr(sText) ' Messagetext
.lpszCaption = StrPtr(sCaption) ' Titel
.dwStyle = iIcon ' Icon setzen
End With
.cancelId = 1
.cButtons = UBound(lArrBtn) + 1 ' Anzahl der Buttons
If iDefBtn = 0 Or iDefBtn > .cButtons Then iDefBtn = 1
.defButton = (iDefBtn - 1) ' DefaultButtonID
.pidButton = VarPtr(lArrBtn(0)) ' IDs übergeben
.ppszButtonText = VarPtr(sArrTxt(0)) ' Buttontexte übergeben
.Timeout = (iTimeOut - 1) ' Timeout setzen, 0=abgeschaltet
End With
i = SoftModalMessageBox(md) ' MsgBox anzeigen
If i = 32000 Then
MsgboxEx = "Timeout"
Else
MsgboxEx = sArrTxt(i - 1) ' Ergebnistext zurückgeben
End If
End Function
Sub Test()
MsgBox MsgboxEx("Bitte wähle eine Option aus!", "Option 1,Option 2,Option 3,Option 4,Option 5,Option 6", "Meine Auswahl", vbExclamation, 0, 1)
End Sub

Gruß
Karl-Heinz

RodFromGermany · 3. Dezember 2024, 17:36

volti schrieb:

Ist aber VBA.....

OK, da werfe ich das Handtuch.

volti · 3. Dezember 2024, 18:31

Hallo zusammen,

ich habe den Fehler gefunden. Falls es jemanden interessiert:

.dwStyle = iIcon + 1

Hier muss eine Button-ID (z.B. 1=vbok) mit angegeben werden. Ich hatte in Unkenntnis nur eine Icon-ID (z.B. 48 =vbExclamation) oder 0 verwendet.
Bei 0 funktioniert es auch nicht.

M.E schon etwas empfindlich, die Reaktion. Ich beschrifte die Buttons ja selbst und dachte, man braucht da keine Button-ID.

Agän wat lörnt.

Gruß
KH

-Franky- · 3. Dezember 2024, 19:56

@volti Dein VBA Code weicht aber auch von meinem VB6/VB.NET Code sehr stark ab und natürlich benötigt jeder Button eine eindeutige ID aus der Enum (außer ID_TIMEOUT). Die ButtonID wird aber nicht im dwStyle angegeben sondern im Array das ja dann pidButton zugewiesen wird. Hinzu kommt das einige MsgBox vbXXX Konstanten ganz andere Werte haben als die in den entsprechenden Enums. vbDefaultButton2 = 256 <> MB_DEFBUTTON2 = 1 usw. Einige vbXXX Konstanten existieren in den Enums und umgekehrt auch nicht.

@RodFromGermany Das hättest doch mal fix von VBA nach .NET übersetzen können. So viele Unterschiede gibt es da gar nicht. Zumal ein .NET Code hier im Thread vorhanden ist.

volti · 3. Dezember 2024, 22:43

Hallo Franky,

ich hatte ja schon geschrieben, dass ich einen anderen Weg als Deinen gehen wollte. Ich brauchte nur entscheidende Hinweise, warum es bei mir zum Abbruch kam.

Natürlich übergebe ich eindeutige Button-IDs. Dazu wird das Array lArrBtn einfach in einer Schleife mit den Werten 1, 2, 3,..... gefüllt.
Warum soll ich zig Konstanten definieren, die ich nicht verwende.
Als Ergebnis liefert meine Funktion einfach den Buttontext zurück, der dann ausgewertet werden kann.
Diese wurden beim Aufruf der MsgBoxEx kommagetrennt übergeben, in ein Array gesplittet und dann der SoftModalMessageBox übergeben.

Fazit: Ich möchte 1 bis 11 Schaltflächen zur Verfügung stellen, mit eigenen Texten versehen und über die eigenen Texte die weitere Programmausführung steuern. Die vordefinierten Konstantenbezeichnungen wie ID_ABORT, ID_OK usw. sind hierbei uninteressant.

Der Fehler war, wie jetzt erkannt, lediglich ein Fehlwert im .dwStyle.
Du übergibst hierzu ja addierend zum Iconwert MB_TYPMASK =&Hff. Das hatte ich nicht gesehen bzw. die Brisanz nicht erkannt. Aber jetzt ist alles klar.

Auch die anderen Konstanten nutze ich nicht, weil z.B. für den Defaultbutton der User der MsgboxEx einfach die Nummer des Button angibt, also 1, 2, 3 usw..

Für die Stylegestaltung werde ich dann wohl noch einige Konstanten so wie Deine bereitstellen, damit der User diese beim Aufruf nutzen kann. Dazu vergleiche ich sie aber erst mal mit den vbKonstanten von Office. Vielleicht kann ich da die nutzen, wenn sie deckungsgleich sind.

Es ist meine Erstversion. Mal sehen, wie funktionable alles ist.

Gruß
KH

volti · 4. Dezember 2024, 11:27

Hallo Franky,

vielleicht noch ein Tipp von Dir....

Help-Button (9) und Close-Button (8) beenden nicht wie die übrigen Buttons die SoftModalMessageBox.

Ich brauche keine Hilfe, der Button soll normal verwendbar sein.
Dazu aktiviere ich die .lpfnMsgBoxCallback = GetAddressOf(AddressOf MsgBoxCallbackProc) und sende dort nach Klick auf den (Hilfe)button ein Postmessage WM_CLOSE an die Dlg.
Funktioniert tadellos.

Aber was ist mit dem Close-Button, dem Button mit der ID=8?
Was muss man wo einstellen/mitgeben, damit auch der die SoftModalMessageBox zurückkehren/beenden lässt oder wo kann man den Klick darauf abfangen?
Ich möchte den ungern in einer eigenen WndProc abfangen müssen.

Gruß KH

-Franky- · 4. Dezember 2024, 20:31

@volti Das der Button mit ID_HELP den Dialog nicht beendet ist so gewollt. Das der Button mit der ID_CLOSE ebenfalls den Dialog nicht schließt ist mir bisher noch gar nicht aufgefallen. Ich vermute mal das da nichts in der MsgBoxCallbackProc dafür ankommt. Wenn dem so ist, dann müsstest mal schauen ob irgendeine WM-Message (evtl. WM_COMMAND) im Owner ankommt. Keine Ahnung ob ein klassisches Subclassing (SetWindowSubclass, RemoveWindowSubclass, DefSubclassProc) des Owner (hWndOwner) in VBA möglich ist.

volti · 4. Dezember 2024, 22:32

Hallo Franky,

ja, der Hilfebutton hat ja eigentlich andere Aufgaben. Hatte ich schon bei der MessageBoxIndirect (Beispiel weiter oben) verwendet. Das sieht mir hier alles sehr ähnlich aus.

Mit VBA kann ich auch alles machen, was Windows hergibt und mich in die Messages einhooken. Z.B. SetWindowsHookExA oder via SetWindowLongA(hwnd, GWL_WNDPROC, AddressOf WindowProc) usw.
Aber das ist mir für den einen Button zur Zeit zu müßig.
Ich habe den 8er-Button jetzt umschifft. Ich denke 10 Buttons sind mehr als genug.

Meine Version bietet jetzt 10 Buttons, TimeOut, individuelles eigenes Icon, MsgBox-Positionierung und Schriftartänderung. Das reicht mir erst mal.
Evtl. später das Icon alternativ aus Datei statt aus Tabellenblatt holen.....

Vielen Dank für Deine Beiträge und vor allem für den Tipp zu dieser mir unbekannten Funktion.

Wen's interessert:

Spoiler anzeigen

Visual Basic-Quellcode

Option Explicit
Private Declare PtrSafe Function SoftModalMessageBox Lib "user32" (pMsgBoxParams As MSGBOXDATA) As Long
Private Declare PtrSafe Function PostMessageA Lib "user32" ( _
ByVal hwnd As LongPtr, ByVal wMsg As Long, _
ByVal wParam As LongPtr, ByVal lParam As LongPtr) As Long
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 GetActiveWindow Lib "user32" () As LongPtr
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 SendDlgItemMessageA Lib "user32" ( _
ByVal hDlg As LongPtr, ByVal nIDDlgItem As Long, ByVal wMsg As Long, _
ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
Private Declare PtrSafe Function SetTimer Lib "user32" ( _
ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, _
ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
Private Declare PtrSafe Function KillTimer Lib "user32" ( _
ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
Private Declare PtrSafe Function GetSystemMetrics Lib "user32" ( _
ByVal nIndex As Long) As Long
Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
Private Declare PtrSafe Function CreateFontA Lib "gdi32.dll" ( _
ByVal nHeight As Long, ByVal nWidth As Long, _
ByVal nEscapement As Long, ByVal nOrientation As Long, _
ByVal fnWeight As Long, ByVal fdwItalic As Long, _
ByVal fdwUnderline As Long, ByVal fdwStrikeOut As Long, _
ByVal fdwCharSet As Long, ByVal fdwOutputPrecision As Long, _
ByVal fdwClipPrecision As Long, ByVal fdwQuality As Long, _
ByVal fdwPitchAndFamily As Long, ByVal lpszFace As String) As LongPtr
Private Type POINTAPI
x As Long
y As Long
End Type
Dim mPtKreuz As POINTAPI
Dim mPT As POINTAPI
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Type MSGBOXPARAMS
cbSize As Long
hWndOwner As LongPtr
hInstance As LongPtr
lpszText As LongPtr
lpszCaption As LongPtr
dwStyle As Long
hIcon As LongPtr ' lpszIcon
dwContextHelpId As Long
lpfnMsgBoxCallback As LongPtr
dwLanguageId As Long
End Type
Private Type MSGBOXDATA
PARAMS As MSGBOXPARAMS
pwndOwner As LongPtr ' Nur intern
dwPadding As Long
wLanguageId As Long
pidButton As LongPtr ' Array (Button-IDs)
ppszButtonText As LongPtr ' Array (Buttontext)
cButtons As Long ' Anzahl der Buttons
defButton As Long ' Button-ID Default
cancelId As Long ' Button-ID Abbruch
Timeout As Long ' Timeout
phwndList As LongPtr ' Nur intern
dwReserved(19) As Long ' Reserviert
End Type
Private Type SCHRIFTART_STRUCT
Groesse As Long
Fett As Boolean
Kursiv As Boolean
Schriftart As String
End Type
Dim mtSCHRIFT As SCHRIFTART_STRUCT
Dim mhDlg As LongPtr, mhTimer As LongPtr, mhIcon As LongPtr, mhFont As LongPtr
Dim msArrTxt() As String
Function MsgboxEx(ByVal sText As String, _
Optional ByVal iStyle As Long = 0, _
Optional ByVal sCaption As String = "Microsoft Excel", _
Optional ByVal sButtontexte As String = "OK", _
Optional ByVal sIconname As String, _
Optional ByVal iTimeOut As Long, _
Optional ByVal iDefBtn As Long, _
Optional ByVal bSysKreuz As Boolean, _
Optional x As Long = 0, Optional y As Long = 0) As String
Dim md As MSGBOXDATA, PT As POINTAPI
Dim lArrBtn() As Long, i As Long
Const ID_CANCEL As Long = 2
Const ID_TIMEOUT As Long = 32000
mPT.x = x: mPT.y = y ' MsgBox Positionen übernehmen
msArrTxt = Split(sButtontexte, ",") ' Buttontexte in Array
If UBound(msArrTxt) > 9 Then Exit Function ' Zu viele Buttontexte
ReDim lArrBtn(UBound(msArrTxt)) ' ID-Array dimensionieren
For i = 1 To UBound(lArrBtn) + 1
lArrBtn(i - 1) = IIf(i < 8, i, i + 2) ' IDs in Array setzen
If i = 10 Then lArrBtn(i - 1) = 9 ' ID_HELP BtnNr korrigieren
Next i
mhIcon = 0: mhDlg = 0: mhFont = 0: mhTimer = 0
If sIconname <> "" Then ' Handle des gefundenen Icons
On Error Resume Next
' <<<< Hier den Tabellennamen für die Icons anpassen! >>>>
mhIcon = Tabelle1.OLEObjects(sIconname).Object.Picture.handle
If mhIcon <> 0 Then iStyle = iStyle Or &H40 ' MB_ICONINFORMATION = &H40
End If
With md
With .PARAMS
.cbSize = LenB(md.PARAMS)
.hWndOwner = Application.hwnd ' Excel-Handle
.hInstance = Application.HinstancePtr ' Excel-Instance
sText = Replace(sText, "¶", vbLf) ' Zeilenumbrüche einsetzen
.lpszText = StrPtr(sText) ' Messagetext (Prompt)
.lpszCaption = StrPtr(sCaption) ' Titel
.dwStyle = iStyle Or 1 ' Ggf. internes Icon setzen
.lpfnMsgBoxCallback = GetAddressOf(AddressOf MsgBoxCallbackProc)
End With
.cancelId = IIf(bSysKreuz, ID_CANCEL, 0) ' Systemkreuz aktivieren
.cButtons = UBound(lArrBtn) + 1 ' Anzahl der Buttons übergeben
If iDefBtn = 0 Or iDefBtn > .cButtons Then iDefBtn = 1
.defButton = (iDefBtn - 1) ' DefaultButton-ID
.pidButton = VarPtr(lArrBtn(0)) ' IDs übergeben
.ppszButtonText = VarPtr(msArrTxt(0)) ' Buttontexte übergeben
.Timeout = (iTimeOut - 1) ' Timeout setzen, -1 = abgeschaltet
End With
mhTimer = SetTimer(0&, 0&, 25, AddressOf MsgBoxCallbackProc)
i = SoftModalMessageBox(md) ' Jetzt MsgBox anzeigen
If mhFont <> 0 Then DeleteObject mhFont ' Font-Objekt löschen
mtSCHRIFT.Groesse = 0
If i = ID_TIMEOUT Then MsgboxEx = "Timeout": Exit Function
If i > 8 Then i = i - 2 ' Ggf. Korrigierung Button-Nr
MsgboxEx = Replace(msArrTxt(i - 1), "&", "") ' Ergebnistext zurückgeben
' Systemkreuz angeklickt?
GetCursorPos PT ' Mausposition holen
If PT.y < mPtKreuz.y Then MsgboxEx = "SystemAbbruch" ' Systemkreuz angeklickt?
End Function
Private Function GetAddressOf(ByVal lpProcAddress As LongPtr) As LongPtr
GetAddressOf = lpProcAddress
End Function
Private Sub MsgBoxCallbackProc()
' TYPE HELP_INFO abgeschaltet, wird nicht benötigt
Dim R As RECT, lPos As Long, hFont As LongPtr
If mhTimer <> 0 Then
KillTimer 0&, mhTimer: mhTimer = 0 ' Timer löschen
mhDlg = GetActiveWindow ' MsgBox-Handle ermitteln
' Icon setzen &H170=STM_SETICON
If mhIcon <> 0 Then SendDlgItemMessageA mhDlg, 20, &H170, mhIcon, 0
' MsgBox positionieren
If mPT.x < 0 Or mPT.y < 0 Then GetCursorPos mPT ' Mausposition holen
If mPT.x > 0 And mPT.y > 0 Then ' MsgBox-Position setzen
GetWindowRect mhDlg, R ' Koordinaten der MsgBox holen
lPos = GetSystemMetrics(0) - (R.Right - R.Left) ' 0=SM_CXSCREEN
If mPT.x > lPos Then mPT.x = lPos
lPos = GetSystemMetrics(1) - (R.Bottom - R.Top) - 50 ' 1=SM_CYSCREEN
If mPT.y > lPos Then mPT.y = lPos ' &H1=SWP_NOSIZE
SetWindowPos mhDlg, 0, mPT.x, mPT.y, 0, 0, &H1 ' MsgBox positionieren
End If
GetWindowRect mhDlg, R ' Koordinaten der MsgBox holen
mPtKreuz.y = R.Top + 40: mPtKreuz.x = R.Right - 40 ' Position des roten Systemkreuzes
With mtSCHRIFT
If .Groesse > 1 Then
mhFont = CreateFontA(.Groesse, 0, 0, 0, _
IIf(.Fett, 700, 400), IIf(.Kursiv, 1, 0), _
0, 0, 0, 0, 0, 0, 0, .Schriftart)
' Schriftart setzen Textfeld-ID=65535 &H30 = WM_SETFONT
SendDlgItemMessageA mhDlg, 65535, &H30, mhFont, True ' Font dem Textfeld zuweisen
End If
End With
Else
' Help-Button wurde geklickt
msArrTxt(1) = msArrTxt(9) ' &H10=WM_CLOSE ' Hilfe-Buttontext für Rückgabe übernehmen
If mhDlg <> 0 Then PostMessageA mhDlg, &H10, 0&, 0& ' MsgBox schließen
End If
End Sub
' Diese Subs sind zum Testen
' Es können 1 bis 10 Buttons angezeigt werden => kommagetrennt angeben
' & vor einem Buchstaben stellt die Shortcut-Taste dar z.B. Alt-S usw.
' ¶ stellt einen Zeilenumbruch dar (vbLf)
' Über x und y kann die Position der MsgBox festgelegt oder an der Mausposition gestartet werden
' Zurückgegeben wird keine Nummer, sondern der Buttontext des geklickten Buttons
Sub Test1()
MsgBox MsgboxEx("Minimum")
End Sub
Sub Test2()
MsgBox MsgboxEx("Dies ist eine Information!¶¶Und noch 'ne Zeile", vbExclamation, "Mein Test", "Verstanden")
End Sub
Sub Test3()
Call MsgboxEx("Dies ist eine Information für kurze Zeit!", vbInformation, "Mein Timeout", "Schließen", , 2000)
End Sub
Sub Test4()
MsgBox MsgboxEx("Bitte wähle eine¶Option aus!", , "Meine Auswahl", _
"Option 1,Option 2,Option 3", "Image1", 0, 2, True)
End Sub
Sub Test5()
MsgBox MsgboxEx("Bitte wähle eine Option aus oder klicke das Systemkreuz für einen Abbruch an", , "Meine Auswahl", _
"O1,O2,O3,O4,O5,O6,O7,O8,O9,O10", "Image2", 0, 0, True)
End Sub
Sub Test6()
MsgBox MsgboxEx("Ich bin jetzt ganz wo anders zu finden", , "Meine Auswahl", _
"&Ja,&Nein,&Vielleicht", "Image3", 0, 0, True, 10, 10)
End Sub
Sub Test7()
With mtSCHRIFT
.Schriftart = "Lucida Handwriting"
.Groesse = 22
.Fett = True
.Kursiv = False
End With
MsgBox MsgboxEx("Mich kann man besser lesen als den Standard!", vbModal, "Große Schrift", _
"Schlumpf &ein,Schlumpf &aus,Schlumpf &um,Ab&schlumpfen,Abbrechen", _
"Image1")
End Sub

Gruß
Karl-Heinz

-Franky- · 4. Dezember 2024, 23:08

@volti Sehr schönes Beispiel für was so alles geht wenn man das Innenleben (APIs/Interfaces usw.) von Windows kennt. Wobei diese MessageBox auch schon ein wenig Staub angesetzt hat. Etwas moderner und flexibler ist da schon der TaskDialog. Den kennst Du sicher schon. Falls nicht, es gibt da zwei APIs. TaskDialog (sehr einfach) und TaskDialogIndirect (mehr Möglichkeiten). Hier gibt es auch ein Bsp, das auch unter VBA funktionieren soll: github.com/fafalone/cTaskDialog64

volti · 4. Dezember 2024, 23:25

Nein, kenne ich nicht. Gucke ich mir gerne mal an.

Nun ja, habe von 1990 bis 2010 gerne mit PowerBasic EXE-Dateien geschrieben. Aber seitdem arbeitsbedingt fast nur noch VBA für Excel, PHP und HTML.

Gruß KH

-Franky- · 5. Dezember 2024, 16:39

@volti Nur für den Fall das Du doch alle 11 Buttons nutzen möchtest. Ich habe mir eine passende Lösung gebastelt. Ich Subclasse tatsächlich den Owner und die Messagebox. Ohne Owner halt nur die Messagebox. Ich habe das jetzt so das wenn beim Owner die Message WM_ACTIVATE -> LoWord(wParam) = WA_INACTIVE (Owner wird inaktiv, Messagebox aktiv) -> lParam = hWnd der Messagebox (hier starte ich das Subclassing der MessageBox) bzw. bei LoWord(wParam) = WA_ACTIVE (Owner wird aktiv da Messagebox geschlossen wurde) beende ich das Subclassing der Messagebox. Beim Subclassing der Messagebox werte ich die Message WM_COMMAND aus die beim klick auf einem Button ausgelöst wird. In LoWord(wParam) stehen dann die entsprechenden ID_HELP, ID_CLOSE usw. Für ID_HELP und ID_CLOSE setze entsprechende Boolean Variablen (um später die Rückgabe der API zu korrigieren) und sende so wie Du ein PostMessage an die MessageBox. Also da geht noch so einiges. Icon in die Captionbar, Icon in einem Button usw usw.

volti · 5. Dezember 2024, 18:02

Ja, Franky,

da geht noch einiges.....

Fragt sich nur, ob man den Aufwand betreiben will und natürlich die Ahnung hat.

Ich mache so was ja gerne, obwohl ich nur Hobby-Programmierer bin, andere schütteln da vielleicht eher den Kopf.

Am Anfang dieses Threads hatte ich mal einen Link auf meine coole Messagebox beim Clever-Excel-Forum hier eingefügt.
Der Code ist dort eingebettet in eine Exceldatei.

Der Code dort kann noch den Hintergrund, die Buttons und den Caption einfärben und vieles mehr.

Ich füge jetzt doch mal den Gesamtcode hier ein. Ohne Gewähr natürlich. Hier geht es um die Excel-Msgbox, gilt aber auch für die API-Msgbox. Bei denen würde ich mich nur anders einhooken, aber es gibt ja immer mehrere Wege.

Passend zu Deiner Ausführung beachte mal die Function WindowProc und dort WM_COMMAND. Hier wird mit wParam = 9 der Helpbutton abgefangen.

Spoiler anzeigen

Quellcode

' Excel-MsgBox Total, verwendet wird die interne MsgBox von Excel
' Bis zu vier Button möglich mit individuellen Buttontexten
' Systemkreuzklick gibt eigenen Text zurück, damit fünf Rückgaben möglich
' Individuelles Icon in MsgBox setzbar
' Textfarbe, Textgröße, Schriftart, fett/kursiv setzbar für Textfeld
' Hintergrund: Farbe oder Struktur oder Bild setzbar
' Transparente Msgbox: Darauf wurde verzichtet
' MsgBox positionierbar und auch Größenänderung möglich
' Alle Button einzeln mit Textfarbe und/oder Hintergrundfarbe versehbar
' Alle Button einzeln verschiebbar und auch Größenänderung möglich
' Timeout setzbar. Nach Timeout eigener Rückgabetext z.B. "TimeOut!"
' CountDown setzbar
' Wegen der individuellen Buttontexte wird der Buttontext des geklickten Buttons zurückgegeben
' Es macht keinen Sinn, in diesem Fall die alten Rückgaben wie vbNo usw. zurückzugeben
Option Explicit
Private Declare PtrSafe Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
Private Declare PtrSafe Function CopyImage Lib "user32" ( _
ByVal handle As LongPtr, ByVal un1 As Long, _
ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As LongPtr
' Timer-Funktionen
Private Declare PtrSafe Function SetTimer Lib "user32" ( _
ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, _
ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
Private Declare PtrSafe Function KillTimer Lib "user32" ( _
ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
' Hooking-Funktioen
Private Declare PtrSafe Function CallWindowProcA Lib "user32" ( _
ByVal lpPrevWndFunc As LongPtr, ByVal hwnd As LongPtr, ByVal Msg As Long, _
ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
#If Win64 Then
Private Declare PtrSafe Function SetWindowLongA Lib "user32" Alias "SetWindowLongPtrA" ( _
ByVal hwnd As LongPtr, ByVal nIndex As Long, _
ByVal dwNewLong As LongPtr) As LongPtr
#Else
Private Declare PtrSafe Function SetWindowLongA Lib "user32" (ByVal hwnd As LongPtr, _
ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
#End If
' Window-Funktionen
Private Declare PtrSafe Function ShowWindow Lib "user32" ( _
ByVal hwnd As LongPtr, ByVal nCmdShow As Long) As Long
Private Declare PtrSafe Function FindWindowA Lib "user32" ( _
ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
Private Declare PtrSafe Function SetWindowTextA Lib "user32" ( _
ByVal hwnd As LongPtr, ByVal lpString As String) As Long
Private Declare PtrSafe Function GetDlgItem Lib "user32" ( _
ByVal hDlg As LongPtr, ByVal nIDDlgItem As Long) As LongPtr
Private Declare PtrSafe Function GetDlgCtrlID Lib "user32" (ByVal hwnd As LongPtr) As Long
Private Declare PtrSafe Function GetClientRect Lib "user32" ( _
ByVal hwnd As LongPtr, lpRect As RECT) As Long
Private Declare PtrSafe Function GetWindowRect Lib "user32" ( _
ByVal hwnd As LongPtr, lpRect As RECT) As Long
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 Const WM_CLOSE As Long = &H10
' ----- nur für Buttons
Private Declare PtrSafe Function GetFocus Lib "user32" () As LongPtr
Private Declare PtrSafe Function SetRect Lib "user32" (lpRect As RECT, _
ByVal X1 As Long, ByVal Y1 As Long, _
ByVal X2 As Long, ByVal Y2 As Long) As Long
' -----
' Message-Funktionen
Private Declare PtrSafe Function SendMessageA Lib "user32" ( _
ByVal hwnd As LongPtr, ByVal wMsg As Long, _
ByVal wParam As LongPtr, lParam As Any) As LongPtr
Private Declare PtrSafe Function PostMessageA Lib "user32" ( _
ByVal hwnd As LongPtr, ByVal wMsg As Long, _
ByVal wParam As LongPtr, lParam As Any) As LongPtr
Private Declare PtrSafe Function SendDlgItemMessageA Lib "user32" ( _
ByVal hDlg As LongPtr, ByVal nIDDlgItem As Long, ByVal wMsg As Long, _
ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
' GDI-Funktionen
Private Declare PtrSafe Function FillRect Lib "user32" (ByVal hDC As LongPtr, _
lpRect As RECT, ByVal hBrush As LongPtr) As Long
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Declare PtrSafe Function BitBlt Lib "gdi32" (ByVal hDestDC As LongPtr, _
ByVal x As Long, ByVal y As Long, _
ByVal nWidth As Long, ByVal nHeight As Long, _
ByVal hSrcDC As LongPtr, _
ByVal xSrc As Long, ByVal ySrc As Long, _
ByVal dwRop As Long) As Long
Private Declare PtrSafe Function CreateCompatibleDC Lib "gdi32" ( _
ByVal hDC As LongPtr) As LongPtr
Private Declare PtrSafe Function SetTextColor Lib "gdi32" (ByVal hDC As LongPtr, _
ByVal crColor As Long) As Long
Private Declare PtrSafe Function SetBkMode Lib "gdi32" (ByVal hDC As LongPtr, _
ByVal nBkMode As Long) As Long
Private Declare PtrSafe Function BeginPaint Lib "user32" (ByVal hwnd As LongPtr, _
lpPaint As PAINTSTRUCT) As LongPtr
Private Declare PtrSafe Function EndPaint Lib "user32" (ByVal hwnd As LongPtr, _
lpPaint As PAINTSTRUCT) As Long
Private Type PAINTSTRUCT
hDC As LongPtr
fErase As Long
rcPaint As RECT
fRestore As Long
fIncUpdate As Long
rgbReserved(0& To 31&) As Byte
End Type
Private Declare PtrSafe Function GetWindowDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hDC As LongPtr) As Long
Private Declare PtrSafe Function DeleteDC Lib "gdi32" (ByVal hDC As LongPtr) As Long
Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
Private Declare PtrSafe Function SelectObject Lib "gdi32" (ByVal hDC As LongPtr, _
ByVal hObject As LongPtr) As LongPtr
Private Declare PtrSafe Function DrawTextA Lib "user32" (ByVal hDC As LongPtr, _
ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, _
ByVal wFormat As Long) As Long
Private Declare PtrSafe Function CreateFontA Lib "gdi32.dll" ( _
ByVal nHeight As Long, ByVal nWidth As Long, _
ByVal nEscapement As Long, ByVal nOrientation As Long, _
ByVal fnWeight As Long, ByVal fdwItalic As Long, _
ByVal fdwUnderline As Long, ByVal fdwStrikeOut As Long, _
ByVal fdwCharSet As Long, ByVal fdwOutputPrecision As Long, _
ByVal fdwClipPrecision As Long, ByVal fdwQuality As Long, _
ByVal fdwPitchAndFamily As Long, ByVal lpszFace As String) As LongPtr
Private Declare PtrSafe Function CreateSolidBrush Lib "gdi32" ( _
ByVal crColor As Long) As LongPtr
Private Declare PtrSafe Function CreateBrushIndirect Lib "gdi32" ( _
lpLogBrush As LOGBRUSH) As LongPtr
Private Type LOGBRUSH
lbStyle As Long
lbColor As Long
lbHatch As LongPtr
End Type
Private Declare PtrSafe Function GetStockObject Lib "gdi32" (ByVal nIndex As Long) As LongPtr
' ----- nur für Buttons
Private Declare PtrSafe Function FrameRect Lib "user32" (ByVal hDC As LongPtr, _
lpRect As RECT, ByVal hBrush As LongPtr) As Long
Private Declare PtrSafe Function DrawFocusRect Lib "user32" (ByVal hDC As LongPtr, _
lpRect As RECT) As Long
Private Declare PtrSafe Function OleTranslateColor Lib "oleaut32.dll" ( _
ByVal clr As OLE_COLOR, ByVal palet As LongPtr, col As Long) As Long
Private Declare PtrSafe Function ColorAdjustLuma Lib "shlwapi.dll" ( _
ByVal clrRGB As Long, ByVal n As Long, ByVal fScale As Long) As Long
Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Type POINTAPI
x As Long
y As Long
End Type
' -----
' Interne Variablen für die MsgBox
Private Type MSGBOX_ITEMS
hwnd As LongPtr
ID As Long
hFont As LongPtr
hBrush As LongPtr
hBrush2 As LongPtr
End Type
Dim mtDlg As MSGBOX_ITEMS ' Dialogbox-Items
Dim mtTF As MSGBOX_ITEMS ' Textfeld-Items
Dim mtCaption As MSGBOX_ITEMS ' Textfeld-Items
Dim mtBtn(1 To 4) As MSGBOX_ITEMS ' Button-Items
Private Type RECTA
Links As Long
Oben As Long
Breit As Long
Hoch As Long
End Type
' Vorgaben für die MsgBox durch den User
Private Type MSGBOX_PARAMS
Text As String
Textfarbe As Long
HGFarbe As Long
Schriftart As String
Schriftgroesse As Long
Fett As Boolean
Kursiv As Boolean
Pos As RECTA ' Positionierungsparameter
ParamEx As Long ' Wenn <>0, dannTitelleiste formatieren
End Type
Dim mtDlgPrm As MSGBOX_PARAMS ' Dialogbox-Parameter
Dim mtCaptionPrm As MSGBOX_PARAMS ' Titelleiste-Parameter
Dim mtBtnPrm(0 To 4) As MSGBOX_PARAMS ' Buttons-Parameter
Dim mhTimer As LongPtr, mhIconPic As LongPtr, mhPic As LongPtr
Dim mhDlgProc As LongPtr, mhBtnProc As LongPtr
Dim mbIcon As Boolean
Dim miAnzBtn As Long, miTimeOut As Long, i As Long
Dim msDlgCaption As String
Private Function MsgboxEx(sText As String, Optional ByVal iDlgStyle As Long, _
Optional sCaption As String = "Microsoft Excel", _
Optional sBtnText As String = "OK", _
Optional sIconname As String, Optional iTimeOut As Long) As String
' Vorbereiten der Messageboxdaten, Aufruf der Excel-MsgBox und Händeln der Rückgabe
Dim mtClearPrm As MSGBOX_PARAMS
Dim Wsh As Worksheet, sArr() As String
Dim iErg As Long
msDlgCaption = sCaption ' Titelleiste global in TYPE
mtDlgPrm.Text = Replace(sText, "¶", vbLf) ' Msg-Text global in TYPE
miTimeOut = iTimeOut ' TimeOutZeit global
' Vorbereiten des eigenen Icons bzw. des Hintergrundbildes
mhIconPic = 0
If sIconname <> "" Then
On Error Resume Next
sArr = Split(sIconname & "!", "!")
If UBound(sArr) > 1 Then
Set Wsh = ThisWorkbook.Sheets(sArr(0)) ' Übergebene Tabelle zu den Icons
Else
Set Wsh = ThisWorkbook.Sheets("Tabelle1") ' Vorgabe Tabelle zu den Icons <<< anpassen >>>
sArr(1) = sArr(0)
End If
mhIconPic = Wsh.OLEObjects(sArr(1)).Object.Picture.handle ' Icon-Handle ermitteln oder Bild-Handle
mbIcon = (iDlgStyle And &HF0)
If mbIcon = False Then iDlgStyle = (iDlgStyle And &HFFF00) ' Wenn Icon aktiviert dann Icon sonst HG-Bild
End If
' Auf ein Icon auf einem Hintegrundbild wurde verzichtet => entweder oder
' Aufbereiten der übergebenen Buttons
sArr = Split("," & sBtnText, ","): miAnzBtn = UBound(sArr) ' Button aufsplitten
For i = 1 To miAnzBtn
mtBtnPrm(i).Text = sArr(i) ' Buttontext in Array
Next i
iDlgStyle = (iDlgStyle And &HFFFF8) Or (miAnzBtn - 1) ' Style festlegen
If miAnzBtn = 4 Then iDlgStyle = iDlgStyle + vbMsgBoxHelpButton ' HelpButton = 4. Button dazu
mhTimer = SetTimer(0&, 0&, 15, AddressOf MsgBoxCallbackProc) ' Timer setzen
' Aufruf der MsgBox und Verarbeitung der User-Auswahl
iErg = MsgBox(mtDlgPrm.Text, iDlgStyle, sCaption) ' Excel-MsgBox starten
Select Case miAnzBtn ' Korrigierung nach
Case 4: iErg = IIf(iErg = 2, 3, iErg - 5) ' Buttonanzahl
Case 3: iErg = iErg - 2
End Select
MsgboxEx = Replace(mtBtnPrm(iErg).Text, "&", "") ' Rückgabe des Buttontextes
' Leeren der globalen Variablen
For i = 1 To 4: mtBtnPrm(i) = mtClearPrm: Next i
mtDlgPrm = mtClearPrm
mtCaptionPrm = mtClearPrm
miTimeOut = 0
End Function
Private Sub MsgBoxCallbackProc()
' Setzt die Button-Texte, die Schriftart und das Icon/HG-Bild individuell
Const GWL_WNDPROC As Long = -4
Const STM_SETICON As Long = &H170
Const HWND_TOPMOST As Long = -1
Dim hWndBtn As LongPtr, hDlg As LongPtr
Dim iFarbe As Long, iBtn As Long, ID As Long, iFlag As Long
Dim tLB As LOGBRUSH, R As RECT
Dim sBtnText As String
KillTimer 0&, mhTimer: mhTimer = 0 ' Timer löschen
mtDlg.hwnd = FindWindowA("#32770", msDlgCaption) ' Handle der MsgBox ermitteln
hDlg = mtDlg.hwnd: If hDlg = 0 Then Exit Sub ' Fehler => raus
' Icon setzen, wenn Iconhandle vorhanden und Icon statt Bild gewünscht
If mhIconPic <> 0 And mbIcon = True Then
SendDlgItemMessageA hDlg, 20, STM_SETICON, mhIconPic, 0 ' Icon ID=20 einsetzen
End If
' Einen Hintergrundpinsel für die MsgBox festlegen
tLB.lbStyle = 0 ' 0=BS_SOLID, 1=BS_HOLLOW, 2=BS_HATCHED, 3=BS_PATTERN
tLB.lbHatch = 5 ' 0=HS_HORIZONTAL, 1=HS_VERTICAL, 4=HS_CROSS, 5=HS_DIACROSS usw.
tLB.lbColor = IIf(mtDlgPrm.HGFarbe, mtDlgPrm.HGFarbe, vbWhite) ' HG-Farbe
mtDlg.hBrush = CreateBrushIndirect(tLB) ' Einen Dlg-Pinsel erstellen
With mtCaptionPrm ' Caption-Pinsel erstellen
If .HGFarbe <> 0 Then mtCaption.hBrush = CreateSolidBrush(Val(.HGFarbe))
End With
' Die Buttons bearbeiten, alle IDs durchgehen und gültige Button bearbeiten
i = 0
For ID = IIf(miAnzBtn = 3, 3, 1) To miAnzBtn + 5 ' Alle Button-ID (max. 9) durchgehen
hWndBtn = GetDlgItem(hDlg, ID) ' Handle des evtl. Button
If hWndBtn <> 0 Then
i = i + 1: iBtn = i ' Button-Anzahl erhöhen, wenn gültig
If miAnzBtn = 4 And ID < 9 Then
iBtn = IIf(ID = 2, 3, i - 1) ' Eine ID tanzt bei 4 Button aus der Reihe
End If
mtBtn(iBtn).hwnd = hWndBtn ' Button-Handle retten
With mtBtnPrm(iBtn)
SetWindowTextA hWndBtn, .Text ' Button beschriften
Call Positionierung(hWndBtn, .Pos) ' Button positionieren
iFarbe = .HGFarbe
If iFarbe > 0 Then
mtBtn(iBtn).hBrush = CreateSolidBrush(iFarbe) ' Einen Button-Pinsel erstellen
OleTranslateColor iFarbe, 0, iFarbe
iFarbe = ColorAdjustLuma(iFarbe, 400, True) ' Farbe aufhellen
mtBtn(iBtn).hBrush2 = CreateSolidBrush(iFarbe) ' Einen Button hell Pinsel erstellen
Call SetzeSchriftsatz(mtBtnPrm(iBtn), mtBtn(iBtn)) ' Font setzen
mhBtnProc = SetWindowLongA(hWndBtn, GWL_WNDPROC, AddressOf WindowProcBtn)
End If
If .Text = "" Then ShowWindow hWndBtn, 0 ' 0 = SW_Hide ' Kein Text, keine Anzeige
End With
End If
Next ID
If mtCaptionPrm.ParamEx <> 0 Then
Call SetzeSchriftsatz(mtCaptionPrm, mtCaption) ' Font für Titelleiste setzen
End If
' Schriftartsatz (Font) holen oder neuen individuellen Font erstellen
mtTF.hwnd = GetDlgItem(hDlg, 65535) ' Handle des Textfeldes holen
Call SetzeSchriftsatz(mtDlgPrm, mtTF)
If mtDlgPrm.Text = "" Then ShowWindow mtTF.hwnd, 0 ' 0 = SW_Hide ' Kein Text, keine Anzeige
' Position und Größe der MsgBox setzen
Call Positionierung(hDlg, mtDlgPrm.Pos, (-1)) ' (-1) = HWND_TOPMOST
If miTimeOut > 0 And mhTimer = 0 Then
mhTimer = SetTimer(0&, 0&, miTimeOut * 1000, AddressOf TimeOutProc) ' Timer setzen für TimeOut
End If
' (Excel)-Msgbox hooken, alle Meldungen für die MsgBox werden umgeleitet
mhDlgProc = SetWindowLongA(hDlg, GWL_WNDPROC, AddressOf WindowProc)
End Sub
Private Sub SetzeSchriftsatz(tPrm As MSGBOX_PARAMS, Typ As MSGBOX_ITEMS)
' Setzt bzw. erstellt einen Schriftsatz für das Textfeld oder einen Button
' Übergeben werden die Types für die Parameter und die Elemente des Objekts
Const WM_SETFONT As Long = &H30
Const WM_GETFONT As Long = &H31
With tPrm
If .Schriftgroesse > 0 And .Schriftart <> "" Then ' Ggf. neuen Font erstellen
Typ.hFont = CreateFontA(.Schriftgroesse, 0, 0, 0, _
IIf(.Fett, 700, 400), IIf(.Kursiv, 1, 0), _
0, 0, 0, 0, 0, 0, 0, .Schriftart)
Else
Typ.hFont = SendMessageA(Typ.hwnd, WM_GETFONT, 0, 0) ' Originalfont des Items holen
End If
End With
SendMessageA Typ.hwnd, WM_SETFONT, Typ.hFont, True ' Font dem Item zuweisen
End Sub
Private Sub SchreibeText(ByVal hDC As LongPtr, R As RECT, tPrm As MSGBOX_PARAMS, Typ As MSGBOX_ITEMS, _
Optional ByVal iStyle As Long = 0)
' Gibt einen Text anhand der festgelegten Parameter aus
SetBkMode hDC, 1 ' 1 = Transparent ' Hintergrundmodus transparent setzen
SelectObject hDC, Typ.hFont ' Font aktivieren
SetTextColor hDC, tPrm.Textfarbe ' Schriftfarbe setzen
DrawTextA hDC, tPrm.Text & vbNullChar, (-1), R, iStyle ' Jetzt Text ausgeben
End Sub
Private Sub TimeOutProc()
' Callback-Funktion händelt den Timeout
KillTimer 0&, mhTimer: mhTimer = 0 ' Timer löschen
i = IIf(miAnzBtn = 1, 1, 2) ' Entsprechenden Rückgabebutton
mtBtnPrm(IIf(miAnzBtn > 2, 3, i)).Text = "Timeout" ' mit neuem Text versehen
PostMessageA mtDlg.hwnd, WM_CLOSE, 0, 0 ' Dialogbox-Schließen-Message senden
End Sub
Private Sub Positionierung(hwnd As LongPtr, tPos As RECTA, Optional iArt As LongPtr)
' Positioniert ein Fenster (Button, MsgBox) und/oder ändert die Größe
' iArt kann z.B. sein: TOP_MOST
Dim iFlag As Long, R As RECT, R2 As RECT
With tPos
If (.Links + .Oben + .Breit + .Hoch) > 0 Then ' Nur wenn min. eine Angabe gemacht
iFlag = &H3 ' &H2=SWP_NOMOVE, &H1=SWP_NOSIZE
GetWindowRect hwnd, R ' Fläche des Items als Default
GetWindowRect mtDlg.hwnd, R2 ' Fläche der MsgBox als Default
If hwnd <> mtDlg.hwnd Then ' Ist Fenster ein Button?
R.Left = R.Left - R2.Left: R.Top = R.Top - R2.Top ' Position im Fenster ausrechnen
End If
R.Right = R.Right - R.Left: R.Bottom = R.Bottom - R.Top ' Breite und Höhe ausrechnen
If .Links > 0 Then R.Left = .Links: iFlag = iFlag And 1
If .Oben > 0 Then R.Top = .Oben: iFlag = iFlag And 1
If .Breit > 20 Then R.Right = .Breit: iFlag = iFlag And 2
If .Hoch > 10 Then R.Bottom = .Hoch: iFlag = iFlag And 2
SetWindowPos hwnd, iArt, R.Left, R.Top, R.Right, R.Bottom, iFlag
End If
' Fenster zentrieren
If (.Links < 0 Or .Oben < 0) And hwnd = mtDlg.hwnd Then
GetWindowRect hwnd, R ' Fläche des Items als Default
If .Links < 0 Then R.Left = GetSystemMetrics(0) \ 2 - (R.Right - R.Left) \ 2
If .Links < 0 Then R.Top = GetSystemMetrics(1) \ 2 - (R.Bottom - R.Top) \ 2
SetWindowPos hwnd, iArt, R.Left, R.Top, 0, 0, &H1
End If
End With
End Sub
Private Function WindowProc(ByVal hwnd As LongPtr, ByVal uMsg As Long, _
ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
' CallbackProzedur für Meldungen der MsgBox
' hWnd ist das Handle der Dlg, lParam ggf. das Handle des Childs, wParam der DC des Childs
Const LR_COPY As Long = &H4
Const SRCCOPY As Long = &HCC0020
Const IMAGE_BITMAP As Long = &H0
Dim tPS As PAINTSTRUCT
Dim hBmp As LongPtr, hMemDC As LongPtr, hDC As LongPtr
Dim B As Long, h As Long
Dim R As RECT, RC As RECT
Select Case uMsg
Case &H85 ' WM_NCPAINT
' Titelleiste und Rahmen beabeiten
If mtCaptionPrm.ParamEx <> 0 Then
With mtCaption
GetClientRect hwnd, RC ' MsgBox-Fläche holen
hDC = GetWindowDC(hwnd) ' Dlg-Fläche incl. Caption/Rahmen
B = RC.Right: h = RC.Bottom + 48
If .hBrush = 0 Then .hBrush = mtDlg.hBrush ' Pinsel ggf. der Dlg-Hintergrund
SetRect R, 0, 0, 9, h: FillRect hDC, R, mtDlg.hBrush ' linker Rahmen
SetRect R, B + 9, 0, B + 18, h: FillRect hDC, R, mtDlg.hBrush ' rechter Rahmen
SetRect R, 0, h - 10, B + 18, h: FillRect hDC, R, mtDlg.hBrush ' unterer Rahmen
SetRect R, 1, 1, B + 18, 38: FillRect hDC, R, .hBrush ' Captionbereich setzen
End With
mtCaptionPrm.Text = msDlgCaption
SchreibeText hDC, R, mtCaptionPrm, mtCaption, &H25
SetRect R, 0, 0, RC.Right + 18, RC.Bottom + 47 ' Rahmenbereich setzen
FrameRect hDC, R, GetStockObject(4) ' 4 = BLACK_BRUSH ' MsgBox-Umrandung zeichnen
ReleaseDC hwnd, hDC
Exit Function
End If
Case &H6 ' WM_ACTIVATE
If mtCaptionPrm.ParamEx <> 0 Then SendMessageA hwnd, &H85, 0, 0 ' WM_NCPAINT-Message senden
Case &HA1 ' WM_NCLBUTTONDOWN
Case &HF ' WM_PAINT
' Ein Hintergrundbild in die MsgBox einfügen
BeginPaint hwnd, tPS ' Gesamte Dlgbox mit Farbe füllen
If mbIcon = False And mhIconPic <> 0 Then
GetClientRect hwnd, R ' MsgBox-Fläche holen
hMemDC = CreateCompatibleDC(tPS.hDC) ' Device Context erstellen
B = R.Right - R.Left: h = R.Bottom - R.Top ' Breite/Höhe ausrechnen
hBmp = CopyImage(mhIconPic, IMAGE_BITMAP, B, h, LR_COPY)
SelectObject hMemDC, hBmp ' BitMap in Device Context ziehen
BitBlt tPS.hDC, 0&, 0&, B, h, hMemDC, 0&, 0&, SRCCOPY
EndPaint hwnd, tPS ' Bereich löschen, Hintergrundfarbe rein
DeleteDC hMemDC: DeleteObject hBmp ' DC und BitMap löschen
' Text neu schreiben
If mtDlgPrm.Text <> "" Then
BeginPaint mtTF.hwnd, tPS
SchreibeText tPS.hDC, R, mtDlgPrm, mtDlg
EndPaint mtTF.hwnd, tPS ' Bereich löschen, Hintergrundfarbe rein
End If
Exit Function
End If
EndPaint mtTF.hwnd, tPS
Case &H112 ' WM_SYSCOMMAND
If wParam = 61536 Then ' System-Kreuz geklickt?
i = IIf(miAnzBtn = 1, 1, 2) ' Entsprechenden Rückgabebutton
mtBtnPrm(IIf(miAnzBtn > 2, 3, i)).Text = "System-Abbruch" ' mit neuem Text versehen
End If
Case &H111 ' WM_COMMAND
If wParam = 9 Then ' Der vierte Button ID=9 wurde geklickt
mtBtnPrm(3).Text = mtBtnPrm(4).Text ' Text 4.Button an Rückgabebutton
PostMessageA hwnd, WM_CLOSE, 0, 0: Exit Function ' Dialogbox-Schließen-Message senden
End If
Case &H136 ' WM_CTLCOLORDLG
WindowProc = mtDlg.hBrush: Exit Function ' Hintergrundfarbe der MsgBox zurückgeben
Case &H135 ' WM_CTLCOLORBTN
WindowProc = mtDlg.hBrush: Exit Function
Case &H138 ' WM_CTLCOLORSTATIC
SetBkMode wParam, 1 ' 1 = Transparent ' wParam => Zeiger auf DC
If lParam = mtTF.hwnd Then ' lParam => Zeiger auf Fenster (Textfeld)
SetTextColor wParam, mtDlgPrm.Textfarbe ' Schriftfarbe des Textfeldes setzen
End If
WindowProc = mtDlg.hBrush: Exit Function ' Hintergrundfarbe des Textfeldes und des Iconfeldes
Case &H2 ' WM_DESTROY ' MsgBox beeenden
' Aufräumen
If mtDlg.hBrush <> 0 Then DeleteObject mtDlg.hBrush: mtDlg.hBrush = 0 ' Pinsel der MsgBox löschen
If mtTF.hFont <> 0 Then DeleteObject mtTF.hFont: mtTF.hFont = 0 ' Font des Textfeldes löschen
For i = 1 To miAnzBtn ' Alle Button durchgehen
With mtBtn(i)
If .hFont <> 0 Then DeleteObject .hFont: .hFont = 0 ' Font des Buttons löschen
If .hBrush <> 0 Then DeleteObject .hBrush: .hBrush = 0 ' Pinsel 1 des Buttons löschen
If .hBrush2 <> 0 Then DeleteObject .hBrush2: .hBrush2 = 0 ' Pinsel 2 des Buttons löschen
End With
Next i
With mtCaption
If .hBrush <> 0 Then DeleteObject .hBrush: .hBrush = 0 ' Pinsel des Caption löschen
If .hFont <> 0 Then DeleteObject .hFont: .hFont = 0 ' Pinsel des Caption löschen
End With
End Select
' Andere Messages an Urspungsprozedur weiterleiten
WindowProc = CallWindowProcA(mhDlgProc, hwnd, uMsg, ByVal wParam, ByVal lParam)
End Function
Private Function WindowProcBtn(ByVal hwnd As LongPtr, ByVal uMsg As Long, _
ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
Dim tPS As PAINTSTRUCT, R As RECT, RW As RECT, tRFocus As RECT, PT As POINTAPI
Const ciStyle As Long = &H25 ' &H1 = DT_CENTER, &H4 = DT_VCENTER, &H20 = DT_SINGLELINE
Select Case uMsg
Case &HF ' WM_PAINT
For i = 1 To miAnzBtn
If mtBtn(i).hwnd = hwnd Then ' Handle (ohne WindowFromPoint) ermitteln
GetCursorPos PT ' Mauscursorposition holen
GetClientRect hwnd, R ' Position/Maße des Buttons in der Msgbox
GetWindowRect hwnd, RW ' Position/Maße des Buttons im Screen
BeginPaint hwnd, tPS
' Buttonfläche ausfüllen
If PT.y >= RW.Top And PT.y < RW.Bottom And PT.x >= RW.Left And PT.x < RW.Right Then
FillRect tPS.hDC, R, mtBtn(i).hBrush2 ' Buttonhintergrund ausfüllen
Else
FillRect tPS.hDC, R, mtBtn(i).hBrush ' Buttonhintergrund ausfüllen
End If
SchreibeText tPS.hDC, R, mtBtnPrm(i), mtBtn(i), ciStyle
' Buttonrahmen zeichnen
FrameRect tPS.hDC, R, GetStockObject(4) ' Buttonumrandung zeichnen
SetRect RW, R.Left + 1, R.Top + 1, R.Right - 1, R.Bottom - 1
FrameRect tPS.hDC, RW, GetStockObject(0) ' Buttonumrandung zeichnen
SetRect RW, R.Left, R.Top, R.Right - 1, R.Bottom - 1
FrameRect tPS.hDC, RW, GetStockObject(3) ' Buttonumrandung zeichnen
' Focusrahmen zeichnen
If GetFocus() = hwnd Then ' Hat der Button den Focus?
SetRect tRFocus, 3, 3, R.Right - 4, R.Bottom - 4 ' Focusbereich setzen
DrawFocusRect tPS.hDC, tRFocus ' Focusrahmen zeichnen
End If
EndPaint hwnd, tPS
Exit Function
End If
Next i
End Select
' Andere Messages an Urspungsprozedur weiterleiten
WindowProcBtn = CallWindowProcA(mhBtnProc, hwnd, uMsg, ByVal wParam, ByVal lParam)
End Function
' ########## Beispiele ##########
Sub AufruftestCool1()
With mtCaptionPrm
.Textfarbe = vbWhite
.HGFarbe = vbRed
.ParamEx = Val(tabMsgBox.Range("$M$8").Value)
End With
With mtDlgPrm
.HGFarbe = RGB(0, 0, 100)
.Schriftart = "Arial"
.Schriftgroesse = 16
.Textfarbe = RGB(255, 255, 100)
End With
With tabMsgBox
.Range("$Q$8").Value = MsgboxEx("Nur noch " & Val(.Range("$M$9").Value) _
& " Sekunden!", vbInformation, "TimeOutbeispiel", _
"Schluss damit", "Icons!Image2", Val(.Range("$M$9").Value))
End With
End Sub

Gruß
Karl-Heinz

Eigene MSGBox - Buttonrückgabe aber wie

Visual Basic-Quellcode

volti schrieb:

Visual Basic-Quellcode

Quellcode

Benutzer online 10

Ähnliche Themen

9 Benutzer haben hier geschrieben