Tipp 0523 Benutzerdefinierte MessageBox
Autor/Einsender:
Datum:
  Detlev Schubert
01.12.2006
Entwicklungsumgebung:   VB 6
Eine Frage, die öfters in unserem Forum gestellt wird, ist die Frage nach einer MessageBox, bei der eigene Buttons verwendet werden können. Hier wird immer argumentiert, dies sei nicht möglich und es wird darauf verwiesen, dass es nur mit einer eigenen Form realisiert werden kann. Dass es jedoch auch anders geht, zeigt dieser Tipp mit einem tiefen Griff in die "API-Trickkiste" sowie einem Subclassing.
Das Beispiel veranschaulicht, dass mit Visual Basic fast nichts unmöglich ist, und es wurde so konzipiert, dass wenn das Schlüsselwort vbCustom fehlt, die ganz normale MsgBox angezeigt wird. Auch können sämtliche bekannten Konstanten verwendet sowie die entsprechenden Icons angezeigt werden. Weiterhin ist als Rückgabewert sowohl der Button-Text als auch der Index möglich.
Wichtiger Hinweis
Im Tipp wird Subclassing verwendet. Das Programm sollte nicht mit dem Beenden-Button der Entwicklungsumgebung (IDE) beendet werden, da dies nahezu immer zum Absturz der IDE führt. Alle nicht gespeicherten Daten gehen damit verloren!!!
Code im Codebereich des Moduls
 
Option Explicit

Private Declare Function CallNextHookEx Lib "user32" (ByVal hHook _
      As Long, ByVal nCode As Long, ByVal wParam As Long, _
      lParam As Any) As Long

Private Declare Function CallWindowProc Lib "user32" Alias _
      "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd _
      As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal _
      lParam As Long) As Long

Private Declare Function GetClassName Lib "user32" Alias _
      "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As _
      String, ByVal nMaxCount As Long) As Long

Private Declare Function SendMessage Lib "user32" Alias _
      "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, _
      ByVal wParam As Long, lParam As Any) As Long

Private Declare Function SetWindowsHookEx Lib "user32" Alias _
      "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As _
      Long, ByVal hmod As Long, ByVal dwThreadId As Long) As Long

Private Declare Function SetWindowLong Lib "user32" Alias _
      "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, _
      ByVal dwNewLong As Long) As Long

Private Declare Function UnhookWindowsHookEx Lib "user32" (ByVal _
      hHook As Long) As Long

Private Declare Sub CopyMemory Lib "kernel32" Alias _
      "RtlMoveMemory" (Destination As Any, Source As Any, _
      ByVal Length As Long)

Private Type CWPSTRUCT
  lParam As Long
  wParam As Long
  message As Long
  hwnd As Long
End Type

Private Const GWL_WNDPROC = (-4)
Private Const WH_CALLWNDPROC = 4
Private Const WM_CTLCOLORBTN = &H135
Private Const WM_CREATE = &H1
Private Const WM_DESTROY = &H2
Private Const WM_SETTEXT = &HC

Private lHook       As Long
Private lPrevWnd    As Long

Private bCustom     As Boolean
Private sButtons()  As String
Private lButton     As Long
Private sHwnd       As String

Public Function MsgBoxEx(ByVal Prompt As String, _
      Optional ByVal Buttons As Long = vbOKOnly, _
      Optional ByVal Title As String, _
      Optional ByVal HelpFile As String, _
      Optional ByVal Context As Long, _
      Optional ByRef CustomButtons As Variant) As Long

  Dim RetVal As Long

  bCustom = (Buttons = vbCustom)
  If bCustom And IsMissing(CustomButtons) Then
    MsgBox "Bei einer benutzerdefinierten MsgBox muss der " & _
           "Schaltflächen-Text im Argument 'CustomButtons' " & _
           "vorgegeben werden.", vbExclamation, "Fehler"
    Exit Function
  End If

  lHook = SetWindowsHookEx(WH_CALLWNDPROC, AddressOf HookWindow, _
        App.hInstance, App.ThreadID)

  If Len(Title) = 0 Then Title = App.Title
  If bCustom Then
    If TypeName(CustomButtons) = "String" Then
      ReDim sButtons(0)
      sButtons(0) = CustomButtons
      Buttons = 0
    Else
      sButtons = CustomButtons
      Buttons = UBound(sButtons)
    End If
  End If

  lButton = 0

  RetVal = MsgBox(Prompt, Buttons, Title, HelpFile, Context)
  UnhookWindowsHookEx lHook

  If bCustom Then RetVal = RetVal - (UBound(CustomButtons) + 1)
  bCustom = False
  MsgBoxEx = RetVal
End Function

Public Function SubMsgBox(ByVal hwnd As Long, ByVal Msg As Long, _
      ByVal wParam As Long, ByVal lParam As Long) As Long

  Dim sText As String

  Select Case Msg
    Case WM_CTLCOLORBTN
      SubMsgBox = CallWindowProc( _
            lPrevWnd, hwnd, Msg, wParam, ByVal lParam)
      If Not bCustom Then Exit Function
      If lButton = 0 Then sHwnd = ""
      If InStr(sHwnd, " " & Trim(Str(lParam)) & " ") Then
        Exit Function
      End If

      sText = sButtons(lButton)
      sHwnd = sHwnd & " " & Trim(Str(lParam)) & " "
      lButton = lButton + 1
      SendMessage lParam, WM_SETTEXT, Len(sText), ByVal sText
      Exit Function

    Case WM_DESTROY
      SetWindowLong hwnd, GWL_WNDPROC, lPrevWnd
  End Select

  SubMsgBox = CallWindowProc( _
        lPrevWnd, hwnd, Msg, wParam, ByVal lParam)
End Function

Private Function HookWindow(ByVal nCode As Long, _
      ByVal wParam As Long, ByVal lParam As Long) As Long

  Dim tCWP As CWPSTRUCT
  Dim sClass As String

  CopyMemory tCWP, ByVal lParam, Len(tCWP)

  If tCWP.message = WM_CREATE Then
    sClass = Space(255)
    sClass = _
        Left(sClass, GetClassName(tCWP.hwnd, ByVal sClass, 255))
    If sClass = "#32770" Then
      lPrevWnd = SetWindowLong(tCWP.hwnd, GWL_WNDPROC, _
            AddressOf SubMsgBox)
    End If
  End If
  HookWindow = CallNextHookEx(lHook, nCode, wParam, ByVal lParam)
End Function
 
Code im Codebereich der Form
 
Option Explicit

Private Sub Command1_Click()
  Dim sButton() As String
  Dim RetVal As Variant

  If Option1(0).Value = True Then
    ReDim sButton(0)
    sButton(0) = "&Absolut"
  ElseIf Option1(1).Value = True Then
    ReDim sButton(1)
    sButton(0) = "&Jubb"
    sButton(1) = "&Eher nicht"
  Else
    ReDim sButton(2)
    sButton(0) = "&Na klar"
    sButton(1) = "&Weniger"
    sButton(2) = "&Nööö"
  End If

  RetVal = MsgBoxEx("Ist diese MessageBox eine Möglichkeit?", _
        vbCustom, Me.Caption, , , sButton)
  MsgBox "Der Index ist" & Str$(RetVal), , Me.Caption
End Sub
 
Weitere Links zum Thema
MessageBox automatisch schließen
MessageBox frei positionieren

Windows-Version
95
98
ME
NT
2000
XP
Vista
Win 7
VB-Version
VBA 5
VBA 6
VB 4/16
VB 4/32
VB 5
VB 6


Download  (4,9 kB) Downloads bisher: [ 850 ]

Vorheriger Tipp Zum Seitenanfang Nächster Tipp

Startseite | Projekte | Tutorials | API-Referenz | VB-/VBA-Tipps | Komponenten | Bücherecke | VB/VBA-Forum | VB.Net-Forum | DirectX-Forum | Foren-Archiv | DirectX | VB.Net-Tipps | Chat | Spielplatz | Links | Suchen | Stichwortverzeichnis | Feedback | Impressum

Seite empfehlen Bug-Report
Letzte Aktualisierung: Sonntag, 15. Mai 2011