Eigene MSGBox - Buttonrückgabe aber wie

  • VB.NET
  • .NET (FX) 4.5–4.8

Es gibt 31 Antworten in diesem Thema. Der letzte Beitrag () ist von volti.

    Hallo Rod,

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

    Visual Basic-Quellcode

    1. ​Option Explicit
    2. Private Declare PtrSafe Function GetProcAddress Lib "kernel32" ( _
    3. ByVal hModule As LongPtr, ByVal lpProcName As String) As LongPtr
    4. Private Declare PtrSafe Function LoadLibraryA Lib "kernel32" ( _
    5. ByVal lpLibFileName As String) As LongPtr
    6. Private Declare PtrSafe Function FreeLibrary Lib "kernel32" ( _
    7. ByVal hLibModule As LongPtr) As Long
    8. Private Type MSGBOXPARAMS
    9. cbSize As Long
    10. hWndOwner As LongPtr
    11. hInstance As LongPtr
    12. lpszText As LongPtr
    13. lpszCaption As LongPtr
    14. dwStyle As Long
    15. lpszIcon As LongPtr
    16. dwContextHelpId As Long
    17. lpfnMsgBoxCallback As LongPtr
    18. dwLanguageId As Long
    19. End Type
    20. Private Type MSGBOXDATA
    21. PARAMS As MSGBOXPARAMS
    22. pwndOwner As LongPtr ' Nur intern
    23. dwPadding As Long
    24. wLanguageId As Long
    25. pidButton As LongPtr ' Array (Button-IDs)
    26. ppszButtonText As LongPtr ' Array (Buttontext)
    27. cButtons As Long ' Anzahl der Buttons
    28. defButton As Long ' Button-ID Default
    29. cancelId As Long ' Button-ID Abbruch
    30. Timeout As Long ' Timeout
    31. phwndList As LongPtr ' Nur intern
    32. dwReserved(19) As Long ' Reserviert
    33. End Type
    34. Private Declare PtrSafe Function SoftModalMessageBox Lib "user32" (pMsgBoxParams As MSGBOXDATA) As Long
    35. Function MsgboxEx(ByVal sText As String, _
    36. Optional ByVal sBtns As String = "OK", _
    37. Optional ByVal sCaption As String = "Microsoft Excel", _
    38. Optional ByVal iIcon As Long, _
    39. Optional ByVal iTimeOut As Long, _
    40. Optional ByVal iDefBtn As Long) As String
    41. Dim md As MSGBOXDATA
    42. Dim lArrBtn() As Long, sArrTxt() As String, i As Long
    43. Dim hModul As LongPtr, hRet As LongPtr
    44. hModul = LoadLibraryA("User32.dll") ' Bibliothek laden
    45. If hModul <> 0& Then
    46. hRet = GetProcAddress(hModul, "SoftModalMessageBox") ' Funktion vorhanden?
    47. FreeLibrary hModul ' Bibliothek schließen
    48. End If
    49. If hRet = 0 Then Exit Function ' Anzeige nicht möglich
    50. sArrTxt = Split(sBtns, ",") ' Buttontexte in Array
    51. ReDim lArrBtn(UBound(sArrTxt)) ' ID-Array dimensionieren
    52. For i = 0 To UBound(lArrBtn): lArrBtn(i) = i + 1: Next i ' IDs in Array setzen
    53. With md
    54. With .PARAMS
    55. .cbSize = LenB(md.PARAMS)
    56. .hWndOwner = Application.hwnd ' Excel-Handle
    57. .hInstance = Application.HinstancePtr ' Excel-Instance
    58. .lpszText = StrPtr(sText) ' Messagetext
    59. .lpszCaption = StrPtr(sCaption) ' Titel
    60. .dwStyle = iIcon ' Icon setzen
    61. End With
    62. .cancelId = 1
    63. .cButtons = UBound(lArrBtn) + 1 ' Anzahl der Buttons
    64. If iDefBtn = 0 Or iDefBtn > .cButtons Then iDefBtn = 1
    65. .defButton = (iDefBtn - 1) ' DefaultButtonID
    66. .pidButton = VarPtr(lArrBtn(0)) ' IDs übergeben
    67. .ppszButtonText = VarPtr(sArrTxt(0)) ' Buttontexte übergeben
    68. .Timeout = (iTimeOut - 1) ' Timeout setzen, 0=abgeschaltet
    69. End With
    70. i = SoftModalMessageBox(md) ' MsgBox anzeigen
    71. If i = 32000 Then
    72. MsgboxEx = "Timeout"
    73. Else
    74. MsgboxEx = sArrTxt(i - 1) ' Ergebnistext zurückgeben
    75. End If
    76. End Function
    77. Sub Test()
    78. 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)
    79. End Sub


    Gruß
    Karl-Heinz

    volti schrieb:

    Ist aber VBA.....
    OK, da werfe ich das Handtuch.
    Falls Du diesen Code kopierst, achte auf die C&P-Bremse.
    Jede einzelne Zeile Deines Programms, die Du nicht explizit getestet hast, ist falsch :!:
    Ein guter .NET-Snippetkonverter (der ist verfügbar).
    Programmierfragen über PN / Konversation werden ignoriert!
    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
    @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. ;)
    Mfg -Franky-

    Dieser Beitrag wurde bereits 1 mal editiert, zuletzt von „-Franky-“ ()

    Neu

    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

    Neu

    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

    Neu

    @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.
    Mfg -Franky-

    Neu

    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

    1. ​Option Explicit
    2. Private Declare PtrSafe Function SoftModalMessageBox Lib "user32" (pMsgBoxParams As MSGBOXDATA) As Long
    3. Private Declare PtrSafe Function PostMessageA Lib "user32" ( _
    4. ByVal hwnd As LongPtr, ByVal wMsg As Long, _
    5. ByVal wParam As LongPtr, ByVal lParam As LongPtr) As Long
    6. Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    7. Private Declare PtrSafe Function GetWindowRect Lib "user32" ( _
    8. ByVal hwnd As LongPtr, lpRect As RECT) As Long
    9. Private Declare PtrSafe Function GetActiveWindow Lib "user32" () As LongPtr
    10. Private Declare PtrSafe Function SetWindowPos Lib "user32" (ByVal hwnd As LongPtr, _
    11. ByVal hWndInsertAfter As LongPtr, ByVal x As Long, ByVal y As Long, _
    12. ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
    13. Private Declare PtrSafe Function SendDlgItemMessageA Lib "user32" ( _
    14. ByVal hDlg As LongPtr, ByVal nIDDlgItem As Long, ByVal wMsg As Long, _
    15. ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
    16. Private Declare PtrSafe Function SetTimer Lib "user32" ( _
    17. ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, _
    18. ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
    19. Private Declare PtrSafe Function KillTimer Lib "user32" ( _
    20. ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
    21. Private Declare PtrSafe Function GetSystemMetrics Lib "user32" ( _
    22. ByVal nIndex As Long) As Long
    23. Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
    24. Private Declare PtrSafe Function CreateFontA Lib "gdi32.dll" ( _
    25. ByVal nHeight As Long, ByVal nWidth As Long, _
    26. ByVal nEscapement As Long, ByVal nOrientation As Long, _
    27. ByVal fnWeight As Long, ByVal fdwItalic As Long, _
    28. ByVal fdwUnderline As Long, ByVal fdwStrikeOut As Long, _
    29. ByVal fdwCharSet As Long, ByVal fdwOutputPrecision As Long, _
    30. ByVal fdwClipPrecision As Long, ByVal fdwQuality As Long, _
    31. ByVal fdwPitchAndFamily As Long, ByVal lpszFace As String) As LongPtr
    32. Private Type POINTAPI
    33. x As Long
    34. y As Long
    35. End Type
    36. Dim mPtKreuz As POINTAPI
    37. Dim mPT As POINTAPI
    38. Private Type RECT
    39. Left As Long
    40. Top As Long
    41. Right As Long
    42. Bottom As Long
    43. End Type
    44. Private Type MSGBOXPARAMS
    45. cbSize As Long
    46. hWndOwner As LongPtr
    47. hInstance As LongPtr
    48. lpszText As LongPtr
    49. lpszCaption As LongPtr
    50. dwStyle As Long
    51. hIcon As LongPtr ' lpszIcon
    52. dwContextHelpId As Long
    53. lpfnMsgBoxCallback As LongPtr
    54. dwLanguageId As Long
    55. End Type
    56. Private Type MSGBOXDATA
    57. PARAMS As MSGBOXPARAMS
    58. pwndOwner As LongPtr ' Nur intern
    59. dwPadding As Long
    60. wLanguageId As Long
    61. pidButton As LongPtr ' Array (Button-IDs)
    62. ppszButtonText As LongPtr ' Array (Buttontext)
    63. cButtons As Long ' Anzahl der Buttons
    64. defButton As Long ' Button-ID Default
    65. cancelId As Long ' Button-ID Abbruch
    66. Timeout As Long ' Timeout
    67. phwndList As LongPtr ' Nur intern
    68. dwReserved(19) As Long ' Reserviert
    69. End Type
    70. Private Type SCHRIFTART_STRUCT
    71. Groesse As Long
    72. Fett As Boolean
    73. Kursiv As Boolean
    74. Schriftart As String
    75. End Type
    76. Dim mtSCHRIFT As SCHRIFTART_STRUCT
    77. Dim mhDlg As LongPtr, mhTimer As LongPtr, mhIcon As LongPtr, mhFont As LongPtr
    78. Dim msArrTxt() As String
    79. Function MsgboxEx(ByVal sText As String, _
    80. Optional ByVal iStyle As Long = 0, _
    81. Optional ByVal sCaption As String = "Microsoft Excel", _
    82. Optional ByVal sButtontexte As String = "OK", _
    83. Optional ByVal sIconname As String, _
    84. Optional ByVal iTimeOut As Long, _
    85. Optional ByVal iDefBtn As Long, _
    86. Optional ByVal bSysKreuz As Boolean, _
    87. Optional x As Long = 0, Optional y As Long = 0) As String
    88. Dim md As MSGBOXDATA, PT As POINTAPI
    89. Dim lArrBtn() As Long, i As Long
    90. Const ID_CANCEL As Long = 2
    91. Const ID_TIMEOUT As Long = 32000
    92. mPT.x = x: mPT.y = y ' MsgBox Positionen übernehmen
    93. msArrTxt = Split(sButtontexte, ",") ' Buttontexte in Array
    94. If UBound(msArrTxt) > 9 Then Exit Function ' Zu viele Buttontexte
    95. ReDim lArrBtn(UBound(msArrTxt)) ' ID-Array dimensionieren
    96. For i = 1 To UBound(lArrBtn) + 1
    97. lArrBtn(i - 1) = IIf(i < 8, i, i + 2) ' IDs in Array setzen
    98. If i = 10 Then lArrBtn(i - 1) = 9 ' ID_HELP BtnNr korrigieren
    99. Next i
    100. mhIcon = 0: mhDlg = 0: mhFont = 0: mhTimer = 0
    101. If sIconname <> "" Then ' Handle des gefundenen Icons
    102. On Error Resume Next
    103. ' <<<< Hier den Tabellennamen für die Icons anpassen! >>>>
    104. mhIcon = Tabelle1.OLEObjects(sIconname).Object.Picture.handle
    105. If mhIcon <> 0 Then iStyle = iStyle Or &H40 ' MB_ICONINFORMATION = &H40
    106. End If
    107. With md
    108. With .PARAMS
    109. .cbSize = LenB(md.PARAMS)
    110. .hWndOwner = Application.hwnd ' Excel-Handle
    111. .hInstance = Application.HinstancePtr ' Excel-Instance
    112. sText = Replace(sText, "¶", vbLf) ' Zeilenumbrüche einsetzen
    113. .lpszText = StrPtr(sText) ' Messagetext (Prompt)
    114. .lpszCaption = StrPtr(sCaption) ' Titel
    115. .dwStyle = iStyle Or 1 ' Ggf. internes Icon setzen
    116. .lpfnMsgBoxCallback = GetAddressOf(AddressOf MsgBoxCallbackProc)
    117. End With
    118. .cancelId = IIf(bSysKreuz, ID_CANCEL, 0) ' Systemkreuz aktivieren
    119. .cButtons = UBound(lArrBtn) + 1 ' Anzahl der Buttons übergeben
    120. If iDefBtn = 0 Or iDefBtn > .cButtons Then iDefBtn = 1
    121. .defButton = (iDefBtn - 1) ' DefaultButton-ID
    122. .pidButton = VarPtr(lArrBtn(0)) ' IDs übergeben
    123. .ppszButtonText = VarPtr(msArrTxt(0)) ' Buttontexte übergeben
    124. .Timeout = (iTimeOut - 1) ' Timeout setzen, -1 = abgeschaltet
    125. End With
    126. mhTimer = SetTimer(0&, 0&, 25, AddressOf MsgBoxCallbackProc)
    127. i = SoftModalMessageBox(md) ' Jetzt MsgBox anzeigen
    128. If mhFont <> 0 Then DeleteObject mhFont ' Font-Objekt löschen
    129. mtSCHRIFT.Groesse = 0
    130. If i = ID_TIMEOUT Then MsgboxEx = "Timeout": Exit Function
    131. If i > 8 Then i = i - 2 ' Ggf. Korrigierung Button-Nr
    132. MsgboxEx = Replace(msArrTxt(i - 1), "&", "") ' Ergebnistext zurückgeben
    133. ' Systemkreuz angeklickt?
    134. GetCursorPos PT ' Mausposition holen
    135. If PT.y < mPtKreuz.y Then MsgboxEx = "SystemAbbruch" ' Systemkreuz angeklickt?
    136. End Function
    137. Private Function GetAddressOf(ByVal lpProcAddress As LongPtr) As LongPtr
    138. GetAddressOf = lpProcAddress
    139. End Function
    140. Private Sub MsgBoxCallbackProc()
    141. ' TYPE HELP_INFO abgeschaltet, wird nicht benötigt
    142. Dim R As RECT, lPos As Long, hFont As LongPtr
    143. If mhTimer <> 0 Then
    144. KillTimer 0&, mhTimer: mhTimer = 0 ' Timer löschen
    145. mhDlg = GetActiveWindow ' MsgBox-Handle ermitteln
    146. ' Icon setzen &H170=STM_SETICON
    147. If mhIcon <> 0 Then SendDlgItemMessageA mhDlg, 20, &H170, mhIcon, 0
    148. ' MsgBox positionieren
    149. If mPT.x < 0 Or mPT.y < 0 Then GetCursorPos mPT ' Mausposition holen
    150. If mPT.x > 0 And mPT.y > 0 Then ' MsgBox-Position setzen
    151. GetWindowRect mhDlg, R ' Koordinaten der MsgBox holen
    152. lPos = GetSystemMetrics(0) - (R.Right - R.Left) ' 0=SM_CXSCREEN
    153. If mPT.x > lPos Then mPT.x = lPos
    154. lPos = GetSystemMetrics(1) - (R.Bottom - R.Top) - 50 ' 1=SM_CYSCREEN
    155. If mPT.y > lPos Then mPT.y = lPos ' &H1=SWP_NOSIZE
    156. SetWindowPos mhDlg, 0, mPT.x, mPT.y, 0, 0, &H1 ' MsgBox positionieren
    157. End If
    158. GetWindowRect mhDlg, R ' Koordinaten der MsgBox holen
    159. mPtKreuz.y = R.Top + 40: mPtKreuz.x = R.Right - 40 ' Position des roten Systemkreuzes
    160. With mtSCHRIFT
    161. If .Groesse > 1 Then
    162. mhFont = CreateFontA(.Groesse, 0, 0, 0, _
    163. IIf(.Fett, 700, 400), IIf(.Kursiv, 1, 0), _
    164. 0, 0, 0, 0, 0, 0, 0, .Schriftart)
    165. ' Schriftart setzen Textfeld-ID=65535 &H30 = WM_SETFONT
    166. SendDlgItemMessageA mhDlg, 65535, &H30, mhFont, True ' Font dem Textfeld zuweisen
    167. End If
    168. End With
    169. Else
    170. ' Help-Button wurde geklickt
    171. msArrTxt(1) = msArrTxt(9) ' &H10=WM_CLOSE ' Hilfe-Buttontext für Rückgabe übernehmen
    172. If mhDlg <> 0 Then PostMessageA mhDlg, &H10, 0&, 0& ' MsgBox schließen
    173. End If
    174. End Sub
    175. ' Diese Subs sind zum Testen
    176. ' Es können 1 bis 10 Buttons angezeigt werden => kommagetrennt angeben
    177. ' & vor einem Buchstaben stellt die Shortcut-Taste dar z.B. Alt-S usw.
    178. ' ¶ stellt einen Zeilenumbruch dar (vbLf)
    179. ' Über x und y kann die Position der MsgBox festgelegt oder an der Mausposition gestartet werden
    180. ' Zurückgegeben wird keine Nummer, sondern der Buttontext des geklickten Buttons
    181. Sub Test1()
    182. MsgBox MsgboxEx("Minimum")
    183. End Sub
    184. Sub Test2()
    185. MsgBox MsgboxEx("Dies ist eine Information!¶¶Und noch 'ne Zeile", vbExclamation, "Mein Test", "Verstanden")
    186. End Sub
    187. Sub Test3()
    188. Call MsgboxEx("Dies ist eine Information für kurze Zeit!", vbInformation, "Mein Timeout", "Schließen", , 2000)
    189. End Sub
    190. Sub Test4()
    191. MsgBox MsgboxEx("Bitte wähle eine¶Option aus!", , "Meine Auswahl", _
    192. "Option 1,Option 2,Option 3", "Image1", 0, 2, True)
    193. End Sub
    194. Sub Test5()
    195. MsgBox MsgboxEx("Bitte wähle eine Option aus oder klicke das Systemkreuz für einen Abbruch an", , "Meine Auswahl", _
    196. "O1,O2,O3,O4,O5,O6,O7,O8,O9,O10", "Image2", 0, 0, True)
    197. End Sub
    198. Sub Test6()
    199. MsgBox MsgboxEx("Ich bin jetzt ganz wo anders zu finden", , "Meine Auswahl", _
    200. "&Ja,&Nein,&Vielleicht", "Image3", 0, 0, True, 10, 10)
    201. End Sub
    202. Sub Test7()
    203. With mtSCHRIFT
    204. .Schriftart = "Lucida Handwriting"
    205. .Groesse = 22
    206. .Fett = True
    207. .Kursiv = False
    208. End With
    209. MsgBox MsgboxEx("Mich kann man besser lesen als den Standard!", vbModal, "Große Schrift", _
    210. "Schlumpf &ein,Schlumpf &aus,Schlumpf &um,Ab&schlumpfen,Abbrechen", _
    211. "Image1")
    212. End Sub


    Gruß
    Karl-Heinz

    Neu

    @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
    Mfg -Franky-

    Neu

    @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.
    Mfg -Franky-

    Neu

    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

    1. ' Excel-MsgBox Total, verwendet wird die interne MsgBox von Excel
    2. ' Bis zu vier Button möglich mit individuellen Buttontexten
    3. ' Systemkreuzklick gibt eigenen Text zurück, damit fünf Rückgaben möglich
    4. ' Individuelles Icon in MsgBox setzbar
    5. ' Textfarbe, Textgröße, Schriftart, fett/kursiv setzbar für Textfeld
    6. ' Hintergrund: Farbe oder Struktur oder Bild setzbar
    7. ' Transparente Msgbox: Darauf wurde verzichtet
    8. ' MsgBox positionierbar und auch Größenänderung möglich
    9. ' Alle Button einzeln mit Textfarbe und/oder Hintergrundfarbe versehbar
    10. ' Alle Button einzeln verschiebbar und auch Größenänderung möglich
    11. ' Timeout setzbar. Nach Timeout eigener Rückgabetext z.B. "TimeOut!"
    12. ' CountDown setzbar
    13. ' Wegen der individuellen Buttontexte wird der Buttontext des geklickten Buttons zurückgegeben
    14. ' Es macht keinen Sinn, in diesem Fall die alten Rückgaben wie vbNo usw. zurückzugeben
    15. Option Explicit
    16. Private Declare PtrSafe Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
    17. Private Declare PtrSafe Function CopyImage Lib "user32" ( _
    18. ByVal handle As LongPtr, ByVal un1 As Long, _
    19. ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As LongPtr
    20. ' Timer-Funktionen
    21. Private Declare PtrSafe Function SetTimer Lib "user32" ( _
    22. ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, _
    23. ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
    24. Private Declare PtrSafe Function KillTimer Lib "user32" ( _
    25. ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
    26. ' Hooking-Funktioen
    27. Private Declare PtrSafe Function CallWindowProcA Lib "user32" ( _
    28. ByVal lpPrevWndFunc As LongPtr, ByVal hwnd As LongPtr, ByVal Msg As Long, _
    29. ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
    30. #If Win64 Then
    31. Private Declare PtrSafe Function SetWindowLongA Lib "user32" Alias "SetWindowLongPtrA" ( _
    32. ByVal hwnd As LongPtr, ByVal nIndex As Long, _
    33. ByVal dwNewLong As LongPtr) As LongPtr
    34. #Else
    35. Private Declare PtrSafe Function SetWindowLongA Lib "user32" (ByVal hwnd As LongPtr, _
    36. ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
    37. #End If
    38. ' Window-Funktionen
    39. Private Declare PtrSafe Function ShowWindow Lib "user32" ( _
    40. ByVal hwnd As LongPtr, ByVal nCmdShow As Long) As Long
    41. Private Declare PtrSafe Function FindWindowA Lib "user32" ( _
    42. ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
    43. Private Declare PtrSafe Function SetWindowTextA Lib "user32" ( _
    44. ByVal hwnd As LongPtr, ByVal lpString As String) As Long
    45. Private Declare PtrSafe Function GetDlgItem Lib "user32" ( _
    46. ByVal hDlg As LongPtr, ByVal nIDDlgItem As Long) As LongPtr
    47. Private Declare PtrSafe Function GetDlgCtrlID Lib "user32" (ByVal hwnd As LongPtr) As Long
    48. Private Declare PtrSafe Function GetClientRect Lib "user32" ( _
    49. ByVal hwnd As LongPtr, lpRect As RECT) As Long
    50. Private Declare PtrSafe Function GetWindowRect Lib "user32" ( _
    51. ByVal hwnd As LongPtr, lpRect As RECT) As Long
    52. Private Declare PtrSafe Function SetWindowPos Lib "user32" ( _
    53. ByVal hwnd As LongPtr, ByVal hWndInsertAfter As LongPtr, _
    54. ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, _
    55. ByVal wFlags As Long) As Long
    56. Private Const WM_CLOSE As Long = &H10
    57. ' ----- nur für Buttons
    58. Private Declare PtrSafe Function GetFocus Lib "user32" () As LongPtr
    59. Private Declare PtrSafe Function SetRect Lib "user32" (lpRect As RECT, _
    60. ByVal X1 As Long, ByVal Y1 As Long, _
    61. ByVal X2 As Long, ByVal Y2 As Long) As Long
    62. ' -----
    63. ' Message-Funktionen
    64. Private Declare PtrSafe Function SendMessageA Lib "user32" ( _
    65. ByVal hwnd As LongPtr, ByVal wMsg As Long, _
    66. ByVal wParam As LongPtr, lParam As Any) As LongPtr
    67. Private Declare PtrSafe Function PostMessageA Lib "user32" ( _
    68. ByVal hwnd As LongPtr, ByVal wMsg As Long, _
    69. ByVal wParam As LongPtr, lParam As Any) As LongPtr
    70. Private Declare PtrSafe Function SendDlgItemMessageA Lib "user32" ( _
    71. ByVal hDlg As LongPtr, ByVal nIDDlgItem As Long, ByVal wMsg As Long, _
    72. ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
    73. ' GDI-Funktionen
    74. Private Declare PtrSafe Function FillRect Lib "user32" (ByVal hDC As LongPtr, _
    75. lpRect As RECT, ByVal hBrush As LongPtr) As Long
    76. Private Type RECT
    77. Left As Long
    78. Top As Long
    79. Right As Long
    80. Bottom As Long
    81. End Type
    82. Private Declare PtrSafe Function BitBlt Lib "gdi32" (ByVal hDestDC As LongPtr, _
    83. ByVal x As Long, ByVal y As Long, _
    84. ByVal nWidth As Long, ByVal nHeight As Long, _
    85. ByVal hSrcDC As LongPtr, _
    86. ByVal xSrc As Long, ByVal ySrc As Long, _
    87. ByVal dwRop As Long) As Long
    88. Private Declare PtrSafe Function CreateCompatibleDC Lib "gdi32" ( _
    89. ByVal hDC As LongPtr) As LongPtr
    90. Private Declare PtrSafe Function SetTextColor Lib "gdi32" (ByVal hDC As LongPtr, _
    91. ByVal crColor As Long) As Long
    92. Private Declare PtrSafe Function SetBkMode Lib "gdi32" (ByVal hDC As LongPtr, _
    93. ByVal nBkMode As Long) As Long
    94. Private Declare PtrSafe Function BeginPaint Lib "user32" (ByVal hwnd As LongPtr, _
    95. lpPaint As PAINTSTRUCT) As LongPtr
    96. Private Declare PtrSafe Function EndPaint Lib "user32" (ByVal hwnd As LongPtr, _
    97. lpPaint As PAINTSTRUCT) As Long
    98. Private Type PAINTSTRUCT
    99. hDC As LongPtr
    100. fErase As Long
    101. rcPaint As RECT
    102. fRestore As Long
    103. fIncUpdate As Long
    104. rgbReserved(0& To 31&) As Byte
    105. End Type
    106. Private Declare PtrSafe Function GetWindowDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    107. Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    108. Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hDC As LongPtr) As Long
    109. Private Declare PtrSafe Function DeleteDC Lib "gdi32" (ByVal hDC As LongPtr) As Long
    110. Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
    111. Private Declare PtrSafe Function SelectObject Lib "gdi32" (ByVal hDC As LongPtr, _
    112. ByVal hObject As LongPtr) As LongPtr
    113. Private Declare PtrSafe Function DrawTextA Lib "user32" (ByVal hDC As LongPtr, _
    114. ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, _
    115. ByVal wFormat As Long) As Long
    116. Private Declare PtrSafe Function CreateFontA Lib "gdi32.dll" ( _
    117. ByVal nHeight As Long, ByVal nWidth As Long, _
    118. ByVal nEscapement As Long, ByVal nOrientation As Long, _
    119. ByVal fnWeight As Long, ByVal fdwItalic As Long, _
    120. ByVal fdwUnderline As Long, ByVal fdwStrikeOut As Long, _
    121. ByVal fdwCharSet As Long, ByVal fdwOutputPrecision As Long, _
    122. ByVal fdwClipPrecision As Long, ByVal fdwQuality As Long, _
    123. ByVal fdwPitchAndFamily As Long, ByVal lpszFace As String) As LongPtr
    124. Private Declare PtrSafe Function CreateSolidBrush Lib "gdi32" ( _
    125. ByVal crColor As Long) As LongPtr
    126. Private Declare PtrSafe Function CreateBrushIndirect Lib "gdi32" ( _
    127. lpLogBrush As LOGBRUSH) As LongPtr
    128. Private Type LOGBRUSH
    129. lbStyle As Long
    130. lbColor As Long
    131. lbHatch As LongPtr
    132. End Type
    133. Private Declare PtrSafe Function GetStockObject Lib "gdi32" (ByVal nIndex As Long) As LongPtr
    134. ' ----- nur für Buttons
    135. Private Declare PtrSafe Function FrameRect Lib "user32" (ByVal hDC As LongPtr, _
    136. lpRect As RECT, ByVal hBrush As LongPtr) As Long
    137. Private Declare PtrSafe Function DrawFocusRect Lib "user32" (ByVal hDC As LongPtr, _
    138. lpRect As RECT) As Long
    139. Private Declare PtrSafe Function OleTranslateColor Lib "oleaut32.dll" ( _
    140. ByVal clr As OLE_COLOR, ByVal palet As LongPtr, col As Long) As Long
    141. Private Declare PtrSafe Function ColorAdjustLuma Lib "shlwapi.dll" ( _
    142. ByVal clrRGB As Long, ByVal n As Long, ByVal fScale As Long) As Long
    143. Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    144. Private Type POINTAPI
    145. x As Long
    146. y As Long
    147. End Type
    148. ' -----
    149. ' Interne Variablen für die MsgBox
    150. Private Type MSGBOX_ITEMS
    151. hwnd As LongPtr
    152. ID As Long
    153. hFont As LongPtr
    154. hBrush As LongPtr
    155. hBrush2 As LongPtr
    156. End Type
    157. Dim mtDlg As MSGBOX_ITEMS ' Dialogbox-Items
    158. Dim mtTF As MSGBOX_ITEMS ' Textfeld-Items
    159. Dim mtCaption As MSGBOX_ITEMS ' Textfeld-Items
    160. Dim mtBtn(1 To 4) As MSGBOX_ITEMS ' Button-Items
    161. Private Type RECTA
    162. Links As Long
    163. Oben As Long
    164. Breit As Long
    165. Hoch As Long
    166. End Type
    167. ' Vorgaben für die MsgBox durch den User
    168. Private Type MSGBOX_PARAMS
    169. Text As String
    170. Textfarbe As Long
    171. HGFarbe As Long
    172. Schriftart As String
    173. Schriftgroesse As Long
    174. Fett As Boolean
    175. Kursiv As Boolean
    176. Pos As RECTA ' Positionierungsparameter
    177. ParamEx As Long ' Wenn <>0, dannTitelleiste formatieren
    178. End Type
    179. Dim mtDlgPrm As MSGBOX_PARAMS ' Dialogbox-Parameter
    180. Dim mtCaptionPrm As MSGBOX_PARAMS ' Titelleiste-Parameter
    181. Dim mtBtnPrm(0 To 4) As MSGBOX_PARAMS ' Buttons-Parameter
    182. Dim mhTimer As LongPtr, mhIconPic As LongPtr, mhPic As LongPtr
    183. Dim mhDlgProc As LongPtr, mhBtnProc As LongPtr
    184. Dim mbIcon As Boolean
    185. Dim miAnzBtn As Long, miTimeOut As Long, i As Long
    186. Dim msDlgCaption As String
    187. Private Function MsgboxEx(sText As String, Optional ByVal iDlgStyle As Long, _
    188. Optional sCaption As String = "Microsoft Excel", _
    189. Optional sBtnText As String = "OK", _
    190. Optional sIconname As String, Optional iTimeOut As Long) As String
    191. ' Vorbereiten der Messageboxdaten, Aufruf der Excel-MsgBox und Händeln der Rückgabe
    192. Dim mtClearPrm As MSGBOX_PARAMS
    193. Dim Wsh As Worksheet, sArr() As String
    194. Dim iErg As Long
    195. msDlgCaption = sCaption ' Titelleiste global in TYPE
    196. mtDlgPrm.Text = Replace(sText, "¶", vbLf) ' Msg-Text global in TYPE
    197. miTimeOut = iTimeOut ' TimeOutZeit global
    198. ' Vorbereiten des eigenen Icons bzw. des Hintergrundbildes
    199. mhIconPic = 0
    200. If sIconname <> "" Then
    201. On Error Resume Next
    202. sArr = Split(sIconname & "!", "!")
    203. If UBound(sArr) > 1 Then
    204. Set Wsh = ThisWorkbook.Sheets(sArr(0)) ' Übergebene Tabelle zu den Icons
    205. Else
    206. Set Wsh = ThisWorkbook.Sheets("Tabelle1") ' Vorgabe Tabelle zu den Icons <<< anpassen >>>
    207. sArr(1) = sArr(0)
    208. End If
    209. mhIconPic = Wsh.OLEObjects(sArr(1)).Object.Picture.handle ' Icon-Handle ermitteln oder Bild-Handle
    210. mbIcon = (iDlgStyle And &HF0)
    211. If mbIcon = False Then iDlgStyle = (iDlgStyle And &HFFF00) ' Wenn Icon aktiviert dann Icon sonst HG-Bild
    212. End If
    213. ' Auf ein Icon auf einem Hintegrundbild wurde verzichtet => entweder oder
    214. ' Aufbereiten der übergebenen Buttons
    215. sArr = Split("," & sBtnText, ","): miAnzBtn = UBound(sArr) ' Button aufsplitten
    216. For i = 1 To miAnzBtn
    217. mtBtnPrm(i).Text = sArr(i) ' Buttontext in Array
    218. Next i
    219. iDlgStyle = (iDlgStyle And &HFFFF8) Or (miAnzBtn - 1) ' Style festlegen
    220. If miAnzBtn = 4 Then iDlgStyle = iDlgStyle + vbMsgBoxHelpButton ' HelpButton = 4. Button dazu
    221. mhTimer = SetTimer(0&, 0&, 15, AddressOf MsgBoxCallbackProc) ' Timer setzen
    222. ' Aufruf der MsgBox und Verarbeitung der User-Auswahl
    223. iErg = MsgBox(mtDlgPrm.Text, iDlgStyle, sCaption) ' Excel-MsgBox starten
    224. Select Case miAnzBtn ' Korrigierung nach
    225. Case 4: iErg = IIf(iErg = 2, 3, iErg - 5) ' Buttonanzahl
    226. Case 3: iErg = iErg - 2
    227. End Select
    228. MsgboxEx = Replace(mtBtnPrm(iErg).Text, "&", "") ' Rückgabe des Buttontextes
    229. ' Leeren der globalen Variablen
    230. For i = 1 To 4: mtBtnPrm(i) = mtClearPrm: Next i
    231. mtDlgPrm = mtClearPrm
    232. mtCaptionPrm = mtClearPrm
    233. miTimeOut = 0
    234. End Function
    235. Private Sub MsgBoxCallbackProc()
    236. ' Setzt die Button-Texte, die Schriftart und das Icon/HG-Bild individuell
    237. Const GWL_WNDPROC As Long = -4
    238. Const STM_SETICON As Long = &H170
    239. Const HWND_TOPMOST As Long = -1
    240. Dim hWndBtn As LongPtr, hDlg As LongPtr
    241. Dim iFarbe As Long, iBtn As Long, ID As Long, iFlag As Long
    242. Dim tLB As LOGBRUSH, R As RECT
    243. Dim sBtnText As String
    244. KillTimer 0&, mhTimer: mhTimer = 0 ' Timer löschen
    245. mtDlg.hwnd = FindWindowA("#32770", msDlgCaption) ' Handle der MsgBox ermitteln
    246. hDlg = mtDlg.hwnd: If hDlg = 0 Then Exit Sub ' Fehler => raus
    247. ' Icon setzen, wenn Iconhandle vorhanden und Icon statt Bild gewünscht
    248. If mhIconPic <> 0 And mbIcon = True Then
    249. SendDlgItemMessageA hDlg, 20, STM_SETICON, mhIconPic, 0 ' Icon ID=20 einsetzen
    250. End If
    251. ' Einen Hintergrundpinsel für die MsgBox festlegen
    252. tLB.lbStyle = 0 ' 0=BS_SOLID, 1=BS_HOLLOW, 2=BS_HATCHED, 3=BS_PATTERN
    253. tLB.lbHatch = 5 ' 0=HS_HORIZONTAL, 1=HS_VERTICAL, 4=HS_CROSS, 5=HS_DIACROSS usw.
    254. tLB.lbColor = IIf(mtDlgPrm.HGFarbe, mtDlgPrm.HGFarbe, vbWhite) ' HG-Farbe
    255. mtDlg.hBrush = CreateBrushIndirect(tLB) ' Einen Dlg-Pinsel erstellen
    256. With mtCaptionPrm ' Caption-Pinsel erstellen
    257. If .HGFarbe <> 0 Then mtCaption.hBrush = CreateSolidBrush(Val(.HGFarbe))
    258. End With
    259. ' Die Buttons bearbeiten, alle IDs durchgehen und gültige Button bearbeiten
    260. i = 0
    261. For ID = IIf(miAnzBtn = 3, 3, 1) To miAnzBtn + 5 ' Alle Button-ID (max. 9) durchgehen
    262. hWndBtn = GetDlgItem(hDlg, ID) ' Handle des evtl. Button
    263. If hWndBtn <> 0 Then
    264. i = i + 1: iBtn = i ' Button-Anzahl erhöhen, wenn gültig
    265. If miAnzBtn = 4 And ID < 9 Then
    266. iBtn = IIf(ID = 2, 3, i - 1) ' Eine ID tanzt bei 4 Button aus der Reihe
    267. End If
    268. mtBtn(iBtn).hwnd = hWndBtn ' Button-Handle retten
    269. With mtBtnPrm(iBtn)
    270. SetWindowTextA hWndBtn, .Text ' Button beschriften
    271. Call Positionierung(hWndBtn, .Pos) ' Button positionieren
    272. iFarbe = .HGFarbe
    273. If iFarbe > 0 Then
    274. mtBtn(iBtn).hBrush = CreateSolidBrush(iFarbe) ' Einen Button-Pinsel erstellen
    275. OleTranslateColor iFarbe, 0, iFarbe
    276. iFarbe = ColorAdjustLuma(iFarbe, 400, True) ' Farbe aufhellen
    277. mtBtn(iBtn).hBrush2 = CreateSolidBrush(iFarbe) ' Einen Button hell Pinsel erstellen
    278. Call SetzeSchriftsatz(mtBtnPrm(iBtn), mtBtn(iBtn)) ' Font setzen
    279. mhBtnProc = SetWindowLongA(hWndBtn, GWL_WNDPROC, AddressOf WindowProcBtn)
    280. End If
    281. If .Text = "" Then ShowWindow hWndBtn, 0 ' 0 = SW_Hide ' Kein Text, keine Anzeige
    282. End With
    283. End If
    284. Next ID
    285. If mtCaptionPrm.ParamEx <> 0 Then
    286. Call SetzeSchriftsatz(mtCaptionPrm, mtCaption) ' Font für Titelleiste setzen
    287. End If
    288. ' Schriftartsatz (Font) holen oder neuen individuellen Font erstellen
    289. mtTF.hwnd = GetDlgItem(hDlg, 65535) ' Handle des Textfeldes holen
    290. Call SetzeSchriftsatz(mtDlgPrm, mtTF)
    291. If mtDlgPrm.Text = "" Then ShowWindow mtTF.hwnd, 0 ' 0 = SW_Hide ' Kein Text, keine Anzeige
    292. ' Position und Größe der MsgBox setzen
    293. Call Positionierung(hDlg, mtDlgPrm.Pos, (-1)) ' (-1) = HWND_TOPMOST
    294. If miTimeOut > 0 And mhTimer = 0 Then
    295. mhTimer = SetTimer(0&, 0&, miTimeOut * 1000, AddressOf TimeOutProc) ' Timer setzen für TimeOut
    296. End If
    297. ' (Excel)-Msgbox hooken, alle Meldungen für die MsgBox werden umgeleitet
    298. mhDlgProc = SetWindowLongA(hDlg, GWL_WNDPROC, AddressOf WindowProc)
    299. End Sub
    300. Private Sub SetzeSchriftsatz(tPrm As MSGBOX_PARAMS, Typ As MSGBOX_ITEMS)
    301. ' Setzt bzw. erstellt einen Schriftsatz für das Textfeld oder einen Button
    302. ' Übergeben werden die Types für die Parameter und die Elemente des Objekts
    303. Const WM_SETFONT As Long = &H30
    304. Const WM_GETFONT As Long = &H31
    305. With tPrm
    306. If .Schriftgroesse > 0 And .Schriftart <> "" Then ' Ggf. neuen Font erstellen
    307. Typ.hFont = CreateFontA(.Schriftgroesse, 0, 0, 0, _
    308. IIf(.Fett, 700, 400), IIf(.Kursiv, 1, 0), _
    309. 0, 0, 0, 0, 0, 0, 0, .Schriftart)
    310. Else
    311. Typ.hFont = SendMessageA(Typ.hwnd, WM_GETFONT, 0, 0) ' Originalfont des Items holen
    312. End If
    313. End With
    314. SendMessageA Typ.hwnd, WM_SETFONT, Typ.hFont, True ' Font dem Item zuweisen
    315. End Sub
    316. Private Sub SchreibeText(ByVal hDC As LongPtr, R As RECT, tPrm As MSGBOX_PARAMS, Typ As MSGBOX_ITEMS, _
    317. Optional ByVal iStyle As Long = 0)
    318. ' Gibt einen Text anhand der festgelegten Parameter aus
    319. SetBkMode hDC, 1 ' 1 = Transparent ' Hintergrundmodus transparent setzen
    320. SelectObject hDC, Typ.hFont ' Font aktivieren
    321. SetTextColor hDC, tPrm.Textfarbe ' Schriftfarbe setzen
    322. DrawTextA hDC, tPrm.Text & vbNullChar, (-1), R, iStyle ' Jetzt Text ausgeben
    323. End Sub
    324. Private Sub TimeOutProc()
    325. ' Callback-Funktion händelt den Timeout
    326. KillTimer 0&, mhTimer: mhTimer = 0 ' Timer löschen
    327. i = IIf(miAnzBtn = 1, 1, 2) ' Entsprechenden Rückgabebutton
    328. mtBtnPrm(IIf(miAnzBtn > 2, 3, i)).Text = "Timeout" ' mit neuem Text versehen
    329. PostMessageA mtDlg.hwnd, WM_CLOSE, 0, 0 ' Dialogbox-Schließen-Message senden
    330. End Sub
    331. Private Sub Positionierung(hwnd As LongPtr, tPos As RECTA, Optional iArt As LongPtr)
    332. ' Positioniert ein Fenster (Button, MsgBox) und/oder ändert die Größe
    333. ' iArt kann z.B. sein: TOP_MOST
    334. Dim iFlag As Long, R As RECT, R2 As RECT
    335. With tPos
    336. If (.Links + .Oben + .Breit + .Hoch) > 0 Then ' Nur wenn min. eine Angabe gemacht
    337. iFlag = &H3 ' &H2=SWP_NOMOVE, &H1=SWP_NOSIZE
    338. GetWindowRect hwnd, R ' Fläche des Items als Default
    339. GetWindowRect mtDlg.hwnd, R2 ' Fläche der MsgBox als Default
    340. If hwnd <> mtDlg.hwnd Then ' Ist Fenster ein Button?
    341. R.Left = R.Left - R2.Left: R.Top = R.Top - R2.Top ' Position im Fenster ausrechnen
    342. End If
    343. R.Right = R.Right - R.Left: R.Bottom = R.Bottom - R.Top ' Breite und Höhe ausrechnen
    344. If .Links > 0 Then R.Left = .Links: iFlag = iFlag And 1
    345. If .Oben > 0 Then R.Top = .Oben: iFlag = iFlag And 1
    346. If .Breit > 20 Then R.Right = .Breit: iFlag = iFlag And 2
    347. If .Hoch > 10 Then R.Bottom = .Hoch: iFlag = iFlag And 2
    348. SetWindowPos hwnd, iArt, R.Left, R.Top, R.Right, R.Bottom, iFlag
    349. End If
    350. ' Fenster zentrieren
    351. If (.Links < 0 Or .Oben < 0) And hwnd = mtDlg.hwnd Then
    352. GetWindowRect hwnd, R ' Fläche des Items als Default
    353. If .Links < 0 Then R.Left = GetSystemMetrics(0) \ 2 - (R.Right - R.Left) \ 2
    354. If .Links < 0 Then R.Top = GetSystemMetrics(1) \ 2 - (R.Bottom - R.Top) \ 2
    355. SetWindowPos hwnd, iArt, R.Left, R.Top, 0, 0, &H1
    356. End If
    357. End With
    358. End Sub
    359. Private Function WindowProc(ByVal hwnd As LongPtr, ByVal uMsg As Long, _
    360. ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
    361. ' CallbackProzedur für Meldungen der MsgBox
    362. ' hWnd ist das Handle der Dlg, lParam ggf. das Handle des Childs, wParam der DC des Childs
    363. Const LR_COPY As Long = &H4
    364. Const SRCCOPY As Long = &HCC0020
    365. Const IMAGE_BITMAP As Long = &H0
    366. Dim tPS As PAINTSTRUCT
    367. Dim hBmp As LongPtr, hMemDC As LongPtr, hDC As LongPtr
    368. Dim B As Long, h As Long
    369. Dim R As RECT, RC As RECT
    370. Select Case uMsg
    371. Case &H85 ' WM_NCPAINT
    372. ' Titelleiste und Rahmen beabeiten
    373. If mtCaptionPrm.ParamEx <> 0 Then
    374. With mtCaption
    375. GetClientRect hwnd, RC ' MsgBox-Fläche holen
    376. hDC = GetWindowDC(hwnd) ' Dlg-Fläche incl. Caption/Rahmen
    377. B = RC.Right: h = RC.Bottom + 48
    378. If .hBrush = 0 Then .hBrush = mtDlg.hBrush ' Pinsel ggf. der Dlg-Hintergrund
    379. SetRect R, 0, 0, 9, h: FillRect hDC, R, mtDlg.hBrush ' linker Rahmen
    380. SetRect R, B + 9, 0, B + 18, h: FillRect hDC, R, mtDlg.hBrush ' rechter Rahmen
    381. SetRect R, 0, h - 10, B + 18, h: FillRect hDC, R, mtDlg.hBrush ' unterer Rahmen
    382. SetRect R, 1, 1, B + 18, 38: FillRect hDC, R, .hBrush ' Captionbereich setzen
    383. End With
    384. mtCaptionPrm.Text = msDlgCaption
    385. SchreibeText hDC, R, mtCaptionPrm, mtCaption, &H25
    386. SetRect R, 0, 0, RC.Right + 18, RC.Bottom + 47 ' Rahmenbereich setzen
    387. FrameRect hDC, R, GetStockObject(4) ' 4 = BLACK_BRUSH ' MsgBox-Umrandung zeichnen
    388. ReleaseDC hwnd, hDC
    389. Exit Function
    390. End If
    391. Case &H6 ' WM_ACTIVATE
    392. If mtCaptionPrm.ParamEx <> 0 Then SendMessageA hwnd, &H85, 0, 0 ' WM_NCPAINT-Message senden
    393. Case &HA1 ' WM_NCLBUTTONDOWN
    394. Case &HF ' WM_PAINT
    395. ' Ein Hintergrundbild in die MsgBox einfügen
    396. BeginPaint hwnd, tPS ' Gesamte Dlgbox mit Farbe füllen
    397. If mbIcon = False And mhIconPic <> 0 Then
    398. GetClientRect hwnd, R ' MsgBox-Fläche holen
    399. hMemDC = CreateCompatibleDC(tPS.hDC) ' Device Context erstellen
    400. B = R.Right - R.Left: h = R.Bottom - R.Top ' Breite/Höhe ausrechnen
    401. hBmp = CopyImage(mhIconPic, IMAGE_BITMAP, B, h, LR_COPY)
    402. SelectObject hMemDC, hBmp ' BitMap in Device Context ziehen
    403. BitBlt tPS.hDC, 0&, 0&, B, h, hMemDC, 0&, 0&, SRCCOPY
    404. EndPaint hwnd, tPS ' Bereich löschen, Hintergrundfarbe rein
    405. DeleteDC hMemDC: DeleteObject hBmp ' DC und BitMap löschen
    406. ' Text neu schreiben
    407. If mtDlgPrm.Text <> "" Then
    408. BeginPaint mtTF.hwnd, tPS
    409. SchreibeText tPS.hDC, R, mtDlgPrm, mtDlg
    410. EndPaint mtTF.hwnd, tPS ' Bereich löschen, Hintergrundfarbe rein
    411. End If
    412. Exit Function
    413. End If
    414. EndPaint mtTF.hwnd, tPS
    415. Case &H112 ' WM_SYSCOMMAND
    416. If wParam = 61536 Then ' System-Kreuz geklickt?
    417. i = IIf(miAnzBtn = 1, 1, 2) ' Entsprechenden Rückgabebutton
    418. mtBtnPrm(IIf(miAnzBtn > 2, 3, i)).Text = "System-Abbruch" ' mit neuem Text versehen
    419. End If
    420. Case &H111 ' WM_COMMAND
    421. If wParam = 9 Then ' Der vierte Button ID=9 wurde geklickt
    422. mtBtnPrm(3).Text = mtBtnPrm(4).Text ' Text 4.Button an Rückgabebutton
    423. PostMessageA hwnd, WM_CLOSE, 0, 0: Exit Function ' Dialogbox-Schließen-Message senden
    424. End If
    425. Case &H136 ' WM_CTLCOLORDLG
    426. WindowProc = mtDlg.hBrush: Exit Function ' Hintergrundfarbe der MsgBox zurückgeben
    427. Case &H135 ' WM_CTLCOLORBTN
    428. WindowProc = mtDlg.hBrush: Exit Function
    429. Case &H138 ' WM_CTLCOLORSTATIC
    430. SetBkMode wParam, 1 ' 1 = Transparent ' wParam => Zeiger auf DC
    431. If lParam = mtTF.hwnd Then ' lParam => Zeiger auf Fenster (Textfeld)
    432. SetTextColor wParam, mtDlgPrm.Textfarbe ' Schriftfarbe des Textfeldes setzen
    433. End If
    434. WindowProc = mtDlg.hBrush: Exit Function ' Hintergrundfarbe des Textfeldes und des Iconfeldes
    435. Case &H2 ' WM_DESTROY ' MsgBox beeenden
    436. ' Aufräumen
    437. If mtDlg.hBrush <> 0 Then DeleteObject mtDlg.hBrush: mtDlg.hBrush = 0 ' Pinsel der MsgBox löschen
    438. If mtTF.hFont <> 0 Then DeleteObject mtTF.hFont: mtTF.hFont = 0 ' Font des Textfeldes löschen
    439. For i = 1 To miAnzBtn ' Alle Button durchgehen
    440. With mtBtn(i)
    441. If .hFont <> 0 Then DeleteObject .hFont: .hFont = 0 ' Font des Buttons löschen
    442. If .hBrush <> 0 Then DeleteObject .hBrush: .hBrush = 0 ' Pinsel 1 des Buttons löschen
    443. If .hBrush2 <> 0 Then DeleteObject .hBrush2: .hBrush2 = 0 ' Pinsel 2 des Buttons löschen
    444. End With
    445. Next i
    446. With mtCaption
    447. If .hBrush <> 0 Then DeleteObject .hBrush: .hBrush = 0 ' Pinsel des Caption löschen
    448. If .hFont <> 0 Then DeleteObject .hFont: .hFont = 0 ' Pinsel des Caption löschen
    449. End With
    450. End Select
    451. ' Andere Messages an Urspungsprozedur weiterleiten
    452. WindowProc = CallWindowProcA(mhDlgProc, hwnd, uMsg, ByVal wParam, ByVal lParam)
    453. End Function
    454. Private Function WindowProcBtn(ByVal hwnd As LongPtr, ByVal uMsg As Long, _
    455. ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
    456. Dim tPS As PAINTSTRUCT, R As RECT, RW As RECT, tRFocus As RECT, PT As POINTAPI
    457. Const ciStyle As Long = &H25 ' &H1 = DT_CENTER, &H4 = DT_VCENTER, &H20 = DT_SINGLELINE
    458. Select Case uMsg
    459. Case &HF ' WM_PAINT
    460. For i = 1 To miAnzBtn
    461. If mtBtn(i).hwnd = hwnd Then ' Handle (ohne WindowFromPoint) ermitteln
    462. GetCursorPos PT ' Mauscursorposition holen
    463. GetClientRect hwnd, R ' Position/Maße des Buttons in der Msgbox
    464. GetWindowRect hwnd, RW ' Position/Maße des Buttons im Screen
    465. BeginPaint hwnd, tPS
    466. ' Buttonfläche ausfüllen
    467. If PT.y >= RW.Top And PT.y < RW.Bottom And PT.x >= RW.Left And PT.x < RW.Right Then
    468. FillRect tPS.hDC, R, mtBtn(i).hBrush2 ' Buttonhintergrund ausfüllen
    469. Else
    470. FillRect tPS.hDC, R, mtBtn(i).hBrush ' Buttonhintergrund ausfüllen
    471. End If
    472. SchreibeText tPS.hDC, R, mtBtnPrm(i), mtBtn(i), ciStyle
    473. ' Buttonrahmen zeichnen
    474. FrameRect tPS.hDC, R, GetStockObject(4) ' Buttonumrandung zeichnen
    475. SetRect RW, R.Left + 1, R.Top + 1, R.Right - 1, R.Bottom - 1
    476. FrameRect tPS.hDC, RW, GetStockObject(0) ' Buttonumrandung zeichnen
    477. SetRect RW, R.Left, R.Top, R.Right - 1, R.Bottom - 1
    478. FrameRect tPS.hDC, RW, GetStockObject(3) ' Buttonumrandung zeichnen
    479. ' Focusrahmen zeichnen
    480. If GetFocus() = hwnd Then ' Hat der Button den Focus?
    481. SetRect tRFocus, 3, 3, R.Right - 4, R.Bottom - 4 ' Focusbereich setzen
    482. DrawFocusRect tPS.hDC, tRFocus ' Focusrahmen zeichnen
    483. End If
    484. EndPaint hwnd, tPS
    485. Exit Function
    486. End If
    487. Next i
    488. End Select
    489. ' Andere Messages an Urspungsprozedur weiterleiten
    490. WindowProcBtn = CallWindowProcA(mhBtnProc, hwnd, uMsg, ByVal wParam, ByVal lParam)
    491. End Function
    492. ' ########## Beispiele ##########
    493. Sub AufruftestCool1()
    494. With mtCaptionPrm
    495. .Textfarbe = vbWhite
    496. .HGFarbe = vbRed
    497. .ParamEx = Val(tabMsgBox.Range("$M$8").Value)
    498. End With
    499. With mtDlgPrm
    500. .HGFarbe = RGB(0, 0, 100)
    501. .Schriftart = "Arial"
    502. .Schriftgroesse = 16
    503. .Textfarbe = RGB(255, 255, 100)
    504. End With
    505. With tabMsgBox
    506. .Range("$Q$8").Value = MsgboxEx("Nur noch " & Val(.Range("$M$9").Value) _
    507. & " Sekunden!", vbInformation, "TimeOutbeispiel", _
    508. "Schluss damit", "Icons!Image2", Val(.Range("$M$9").Value))
    509. End With
    510. End Sub


    Gruß
    Karl-Heinz