Auswahldialogboxen erstellen

[volti]

Liebe Leserin, lieber Leser,

manchmal wünscht man sich eine Dialogbox, mit der aus einer Vielzahl von Möglichkeiten ausgewählt werden kann oder eine Dialogbox, mit der mittels Checkboxen ene individuelle Zusammenstellung getroffen werden kann.

Da ich diese Funktionalitäten gerade für ein eigenes Projekt brauchte, habe ich mir das zusammengestellt und stelle das hier gerne zur Verfügung.

Normalerweise würde man das in Excel über eine Userform lösen. Dass es aber auch anders geht, möchte ich gern mal zeigen.

Wir nehmen eine ganz normale Inputbox und bauen sie nach unserem Geschmack um. Die Wahl fällt auf eine Inputbox, weil diese schon eine ganze Reihe an Funktionen und Objekten mitbringt.

• Die Editbox wird unsichtbar geschaltet. Hier werden die Ergebnisse vorgehalten bis durch Schließen der Inputbox das Endergebnis ohne unser Zutun zurückgegeben wird.
• Die beiden Button verschieben wir nach unten. Sieht m.E. besser aus.
• Dann erstellen wir die gewünschte Anzahl an Radio- oder Checkboxen
• Bei Bedarf fügen wir noch ein ansprechendes Icon hinzu

Fertig...

Natürlich brauchen wir jetzt noch eine entsprechende Prozedur, die nach Anklicken eines der Checkboxen das Ergebnis in die Editbox schafft. Aber das kann man ja alles im Code nachsehen.

In der anliegenden Datei habe ich ein paar Beispiele zusammengestellt, auch eins mit eigenem Icon. Da sieht das doch gleich viel besser aus.

   

  Inputbox_Checkboxen.xlsb (Größe: 98,94 KB / Downloads: 14)



So, und nun viel Spaß beim Anwenden und Ausprobieren...

Beispielcode:

Code:

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 GetActiveWindow Lib "user32" () As LongPtr
Private Declare PtrSafe Function ShowWindow Lib "user32" ( _
        ByVal hWnd As LongPtr, ByVal nCmdShow As Long) 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 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 CreateWindowExA Lib "user32" ( _
        ByVal dwExStyle As Long, _
        ByVal lpClassName As String, ByVal lpWindowName As String, _
        ByVal dwStyle As Long, _
        ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, _
        ByVal hWndParent As LongPtr, _
        ByVal hMenu As LongPtr, ByVal hInstance As LongPtr, _
        lpParam As Any) 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
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 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

Private Const WS_CB_MYSTYLE As Long = &H50000003 ' WS_CHILD + WS_VISIBLE + BS_AUTOCHECKBOX

Dim mhTimer As LongPtr, mhEdit As LongPtr
Dim msCBItems() As String, msDefault As String
Dim miAnz As Integer, miBreit As Long
Dim glpOldProc As LongPtr

Private Function CheckBoxDialog(sMsgTxt As String, sCaption As String, sCBElemente As String, _
                                Optional sDefault As Variant, Optional iBreit As Long = 500) As String
' Anzeigen einer Inputbox als Auswahlbox mit Checkboxen
  msCBItems = Split(sCBElemente, ",")                                  ' Range mit Elementen global
  miAnz = UBound(msCBItems) + 1                                        ' Anzahl der Elemente
  msDefault = Left$(sDefault & "00000000000000000000", miAnz)          ' Vorgabe global
  miBreit = iBreit                                                     ' Breite global
  mhTimer = SetTimer(0&, 0&, 10, AddressOf CheckboxProc)               ' Timer setzen
  CheckBoxDialog = InputBox(sMsgTxt, sCaption, msDefault)              ' (Excel)-Inputbox starten
End Function

Private Sub CheckboxProc()
' Und setzt die Hooking-Prozeduren für die InputBox
  Dim i As Integer, hwndDlg As LongPtr, hWnd As LongPtr, hFont As LongPtr
  Dim y As Long, x As Long
  
  KillTimer 0&, mhTimer: mhTimer = 0                                   ' Timer löschen
  hwndDlg = GetActiveWindow                                            ' Handle der Dialogbox holen
  mhEdit = GetDlgItem(hwndDlg, 4900)                                   ' Handle der Editbox holen
  ShowWindow mhEdit, 0                                                 ' Editbox ausblenden und updaten
' Checkboxen  erstellen, mit Text versehen und anzeigen
  x = miBreit \ 2: y = 55
  For i = 0 To miAnz - 1
      hWnd = CreateWindowExA(0&, "Button", " " & msCBItems(i), WS_CB_MYSTYLE, _
             20, y, 450, 20, hwndDlg, 10 + i, Application.HinstancePtr, 0)
' Schriftart ändern      &H30 = WM_SETFONT          &H31 = WM_GETFONT
      SendMessageA hWnd, &H30, SendMessageA(mhEdit, &H31, 0, 0), True
' Checkboxen vorbelegen                                          &HF1 _
 = BM_SETCHECK
      If Mid$(msDefault, i + 1, 1) = "1" Then SendMessageA hWnd, &HF1, 1, 0
' (Excel)-Inputbox hooken               -4 = GWL_WNDPROC
      glpOldProc = SetWindowLongA(hWnd, -4, AddressOf WindowProc)      ' Alte Prozeduradresse retten
      y = y + 30
  Next i
  y = y + 10                                           ' &H1=SWP_NOSIZE
  SetWindowPos GetDlgItem(hwndDlg, 1), 0, x - 120, y, 0, 0, &H1        ' OK-Button verschieben
  SetWindowPos GetDlgItem(hwndDlg, 2), 0, x + 10, y, 0, 0, &H1         ' Abbrechen-Button verschieben
  SetWindowPos hwndDlg, 0, 0, 0, miBreit, y + 100, &H2 ' &H2=SWP_NOMOVE' Dialogbox-Größe anpassen
End Sub

Private Function WindowProc(ByVal hWnd As LongPtr, ByVal uMsg As Long, _
                            ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
' Verarbeitet die Messages für die Checkboxen  (Typ _
 Stringverarbeitung)
  Dim sTxt As String

  If uMsg = &H201 Then  ' &H201 = WM_LBUTTONDOWN                       ' Linke Maustaste gedrückt
     sTxt = Space$(miAnz)
     SendMessageA mhEdit, &HD, miAnz + 1, ByVal sTxt ' &HD = WM_GETTEXT  Text aus Editbox holen
     Mid$(sTxt, GetDlgCtrlID(hWnd) - 9, 1) = IIf(SendMessageA(hWnd, &HF0, 0, 0) = 0, "1", "0")
     SendMessageA mhEdit, &HC, miAnz, ByVal sTxt  ' &HC = WM_SETTEXT     Editbox mit neuem Text updaten
  End If
  WindowProc = CallWindowProcA(glpOldProc, hWnd, uMsg, wParam, lParam) ' Andere Messages weiterleiten
End Function


' _
 #####################################################################
Sub AufruftestAuswahlbox1()
  Dim sTxt As String, sOut As String, i As Integer
  
  sTxt = CheckBoxDialog("Bitte wähle Deine Wünsche durch Anklicken aus!", "Auswahl der Zutaten", _
                        "mit Erdbeeren,mit Soße,mit Sahne,mit Kirschsaft,im Pappbecher,zum Mitnehmen", "111", 400)
  For i = 1 To Len(sTxt)
    If Mid$(sTxt, i, 1) = "1" Then sOut = sOut & msCBItems(i - 1) & vbCr
  Next i
  MsgBox "Gewählt wurde:" & vbCr & sOut
End Sub

_________
viele Grüße
Karl-Heinz