Anzeigebox mit bis zu 10 Schaltflächen

[volti]

Hallo liebe Leserin, lieber Leser,

wer's brauchen kann.....

Standardmäßig kann man in seiner Msgbox maximal drei Schaltflächen + 1 Hilfebutton anzeigen lassen.
Wer mehr möchte, musste bisher andere Wege gehen, z.B. eines der vielen Beispiele hier im Forum nutzen.

Aber Windows stellt auch eine MsgBox-Version zur Verfügung, die optional bis zu elf Buttons anzeigen kann.
Zwei davon sind abweichend und einer schwer zu handeln. Deshalb kann man mit dem hier gezeigten Code nur maximal 10 Buttons anzeigen lassen.

Evtl. Anwendungsmöglichkeit: Auswahl aus einer Vielzahl von Optionen.....

Diese Minimalversion kann 9 Buttons mit individuellem Buttontext anzeigen lassen und bietet auch eine TimeOut-Möglichkeit.

Code:

Option Explicit

Private Declare PtrSafe Function SoftModalMessageBox Lib "user32" (pMsgBoxParams As MSGBOXDATA) As Long

Private Type MSGBOXPARAMS
  cbSize             As Long
  hWndOwner          As LongPtr
  hInstance          As LongPtr
  lpszText           As LongPtr
  lpszCaption        As LongPtr
  dwStyle            As Long
  hIcon              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

Dim mhTimer As LongPtr, 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 iTimeOut As Long, _
                  Optional ByVal iDefBtn As Long, _
                  Optional ByVal bSysKreuz As Boolean) As String
  Dim md As MSGBOXDATA
  Dim lArrBtn() As Long, i As Long
  Const ID_CANCEL  As Long = 2
  Const ID_TIMEOUT As Long = 32000
  
  msArrTxt = Split(sButtontexte, ",")                       ' Buttontexte in Array
  If UBound(msArrTxt) > 8 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
  Next i
  
  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 = 0
      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
  
  i = SoftModalMessageBox(md)                               ' Jetzt MsgBox anzeigen
 
  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
End Function

' 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)
' Zurückgegeben wird keine Nummer, sondern der Buttontext des geklickten Buttons
Sub Test11()
  MsgBox MsgboxEx("Minimum")
End Sub

Sub Test12()
  MsgBox MsgboxEx("Dies ist eine Information!¶¶Und noch 'ne Zeile", vbExclamation, "Mein Test", "Verstanden")"
End Sub

Sub Test13()
  Call MsgboxEx("Dies ist eine Information für kurze Zeit!", vbInformation, "Mein Timeout", "Schließen", 2000)
End Sub

Sub Test14()
    MsgBox MsgboxEx("Bitte wähle eine¶Option aus!", , "Meine Auswahl", _
                    "Option 1,Option 2,Option 3", 0, 2, True)
End Sub

Sub Test15()
    MsgBox MsgboxEx("Bitte wähle eine Option aus oder klicke das Systemkreuz für einen Abbruch an", vbExclamation, "Meine Auswahl", _
                     "O1,O2,O3,O4,O5,O6,O7,O8,O9,O10", 0, 0, True)
End Sub

Als zweites zeige ich eine noch umfangreichere Version, die bis zu 10 Buttons, Timeout, eigenes Icon, MsgBox-Positionierung, Individuelle Schriftart und mehr bietet.

   

Code:

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

_________
viele Grüße
Karl-Heinz