Inputbox als (abhängige) Combobox verwenden

[volti]

Hallo liebe Leserin, lieber Leser,

für die Auswahl eines Elements aus einer Liste bietet sich ja die Verwendung einer Combobox an.
Diese wird meistens in eine Userform eingebettet oder über die Funktion "Datenprüfung" direkt auf dem Tabellenblatt platziert.

Dass es aber auch anders geht, möchte ich mit diesem kleinen Beispiel mal aufzeigen.

Eine Möglichkeit besteht darin, über die API ein passendes Fenster zu erstellen und darin dann eine Combobox und weitere Elemente einzubetten. Ein wenig aufwändig.

Für deutlich weniger Aufwand bietet sich jedoch z.B. die Verwendung der beliebten Inputbox an.
Diese bringt schon einige Funktionalitäten von Haus aus mit und lässt sich mit ein paar API-Funktionen leicht manipulieren.

Hierzu beschaffen wir uns z.B. über den Timer das Handle (interner Zeiger auf die Inputbox) und können nun loslegen mit unserer Manipulation.

Wir fügen eine Combobox hinzu und legen sie über die vorher ausgeblendete Editbox. Nach dem Hinzufügen der gewünschten Elemente ist unsere Comboboxdialogbox auch schon fertig.
Nach Auswahl eines Elements wird dieses in die Originaleditbox überführt. Damit überlassen wir der Inputbox das Managen der Rückgabe und haben keine Arbeit damit.

PS. Der u.a. Code erstellt eine ComboboxListe nur für die Auswahl. In der anliegenden Datei findest Du auch noch ein Beispiel für eine gemischte Combobox mit Auswahl- und Eingabemöglichkeit.
Ein drittes Beispiel zeigt zwei abhängige Comboboxen. (Anzeige von Städten nach Vorauswahl des Bundeslandes)


  Inputbox_Combobox.xlsb (Größe: 61,17 KB / Downloads: 13)

Und nun viel Spaß beim Ausprobieren...

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 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
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
Private Declare PtrSafe Function GetDlgItem Lib "user32" ( _
        ByVal hDlg As LongPtr, ByVal nIDDlgItem As Long) As LongPtr
Private Declare PtrSafe Function GetWindowTextA Lib "user32" ( _
        ByVal hwnd As LongPtr, ByVal lpString As String, _
        ByVal cch As Long) As Long
Private Declare PtrSafe Function SetWindowTextA Lib "user32" ( _
        ByVal hwnd As LongPtr, ByVal lpString As String) As Long
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, ByVal lParam As LongPtr) As Long
Private Declare PtrSafe Function ShowWindow Lib "user32" ( _
        ByVal hwnd As LongPtr, ByVal nCmdShow As Long) As Long
Private Const WS_CB_MYSTYLE As Long = &H50000303 ' WS_CHILD + WS_VISIBLE + CBS_DROPDOWNLIST + CBS_HASSTRINGS + CBS_SORT
Private Const WS_VSCROLL    As Long = &H200000

Dim glpOldProc     As LongPtr, mhTimer As LongPtr, mhWndEdit As LongPtr
Dim msCBElemente() As String, msDefault As String

Private Function InputBoxEx(sMsgTxt As String, sCaption As String, _
                            sCBElemente As String, Optional sDefault As String) As Variant
' Anzeigen einer Inputbox als Combobox
  msCBElemente = Split(sCBElemente, ",")                        ' Range mit Elementen global
  msDefault = sDefault                                          ' Defaulttext global
  mhTimer = SetTimer(0&, 0&, 10, AddressOf ComboBoxHookProc)    ' Timer setzen
  InputBoxEx = InputBox(sMsgTxt, sCaption, sDefault)            ' (Excel)-Inputbox starten
End Function

Private Sub ComboBoxHookProc()
' Setzt die Hooking-Prozedur für die InputBox
  Dim i As Integer, hWndCB As LongPtr, sArr() As String
  
  KillTimer 0&, mhTimer: mhTimer = 0                            ' Timer löschen
 
  mhWndEdit = GetDlgItem(GetActiveWindow, 4900)  ' Edit_ID      ' Handle der Editbox
  ShowWindow mhWndEdit, 0                                       ' Editbox ausblenden

' Combobox erstellen, mit Eelementen füllen  und anzeigen
  hWndCB = CreateWindowExA(0&, "Combobox", "", WS_CB_MYSTYLE Or WS_VSCROLL, _
           12, 110, 464, 20, GetActiveWindow, _
           0&, Application.HinstancePtr, 0&)
  For i = 0 To UBound(msCBElemente)
' Element zufügen          &H143 = CB_ADDSTRING
      SendMessageA hWndCB, &H143, ByVal CLng(0), ByVal msCBElemente(i)
  Next i
  SetWindowTextA hWndCB, msDefault                              ' Combobox vorbelegen

' (Excel)-Inputbox hooken             -4 = GWL_WNDPROC
  glpOldProc = SetWindowLongA(hWndCB, -4, AddressOf WindowProc) ' Alte Prozeduradresse retten
End Sub

Private Function WindowProc(ByVal hwnd As LongPtr, ByVal uMsg As Long, _
                            ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
  Dim sText As String * 255
  
' Verarbeitet die Messages für die Combobox
  If uMsg = &H111 Then                       ' &H111 = WM_COMMAND
     If wParam = 66536 Then PostMessageA hwnd, &H111, 0, 0
     GetWindowTextA hwnd, sText, 255                            ' Text aus Combobox holen
     SetWindowTextA mhWndEdit, sText                            ' Editbox damit updaten
  End If
  WindowProc = CallWindowProcA(glpOldProc, hwnd, uMsg, wParam, lParam) ' Andere Messages weiterleiten
End Function


' _
 #####################################################################
Sub AufruftestCombobox1()
  MsgBox InputBoxEx("Bitte wähle einen Namen aus!", "Namen auswählen", "Hubert,Anna,Horst,Udo,Uwe,Bertha,Karl", "Hubert")
End Sub

_________
viele Grüße
Karl-Heinz

[volti]

Nachtrag...

Für eine einfache Combobox findest Du noch eine abgespeckte Version, die deutlich weniger Code benötigt.
Hierbei wird die Editbox gelöscht statt ausgeblendet und die Combobox mit der ehemaligen ID der Editbox versehen.

Somit kann das WindowProc zum Handeln der Messages entfallen, da das komplette Management jetzt von der Inputbox übernommen wird.

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 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 GetDlgItem Lib "user32" ( _
        ByVal hDlg As LongPtr, ByVal nIDDlgItem As Long) As LongPtr
Private Declare PtrSafe Function SetWindowTextA Lib "user32" ( _
        ByVal hwnd As LongPtr, ByVal lpString As String) As Long
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 DestroyWindow Lib "user32" (ByVal hwnd As LongPtr) As Long
Private Const WS_CB_MYSTYLE As Long = &H50000302 ' WS_CHILD + WS_VISIBLE + CBS_DROPDOWNLIST + CBS_HASSTRINGS + CBS_SORT
Private Const WS_VSCROLL    As Long = &H200000

Dim mhTimer As LongPtr
Dim msCBElemente() As String, msDefault As String

Private Function InputBoxEx(sMsgTxt As String, sCaption As String, _
                            sCBElemente As String, Optional sDefault As String) As Variant
' Anzeigen einer Inputbox als Combobox
  msCBElemente = Split(sCBElemente, ",")                        ' Range mit Elementen global
  msDefault = sDefault                                          ' Defaulttext global
  mhTimer = SetTimer(0&, 0&, 10, AddressOf ComboBoxHookProc)    ' Timer setzen
  InputBoxEx = InputBox(sMsgTxt, sCaption, sDefault)            ' (Excel)-Inputbox starten
End Function

Private Sub ComboBoxHookProc()
' Setzt die Hooking-Prozedur für die InputBox
  Dim i As Integer, hWndCB As LongPtr
  
  KillTimer 0&, mhTimer: mhTimer = 0                            ' Timer löschen
  DestroyWindow GetDlgItem(GetActiveWindow, 4900)  ' Edit_ID    ' Editbox löschen

' Combobox erstellen, mit Elementen füllen  und anzeigen
  hWndCB = CreateWindowExA(0&, "Combobox", "", WS_CB_MYSTYLE Or WS_VSCROLL, _
           12, 110, 464, 20, GetActiveWindow, _
           0&, Application.HinstancePtr, 0)
  For i = 0 To UBound(msCBElemente)
' Element zufügen          &H143 = CB_ADDSTRING
      SendMessageA hWndCB, &H143, ByVal CLng(0), ByVal msCBElemente(i)
  Next i
  SetWindowTextA hWndCB, msDefault                              ' Combobox vorbelegen
  SetWindowLongA hWndCB, -12, 4900  ' (-12) = GWL_ID            ' ID setzen
End Sub

' #####################################################################
Sub AufruftestCombobox4()
  MsgBox InputBoxEx("Bitte wähle einen Namen aus!", "Namen auswählen", "Hubert,Anna,Horst,Udo,Uwe,Karl", "Hubert")
End Sub

_________
viele Grüße
Karl-Heinz

[volti]

Hallo liebe Leserin, lieber Leser,

hier noch ein interessanter Nachtrag zu den bereits gezeigten Beispielen.

Standardmäßig wird bei den neuen Elementen (hier Combobox) die System-Schriftart verwendet. Ich persönlich finde sie nicht so schön, so dass ich für mich nach einer Lösung gesucht hatte.

Bevor wir nun einen neuen Font erstellen, verwenden und löschen müssen, nehmen wir doch einfach die Schriftart der Original-Editbox.

Mit diesem Code hier kann die Schriftart auf die neue Combobox übertragen werden. Das machen wir gleich ohne den Umweg über ein Handle.
SendMessage hWndCB, WM_SETFONT, SendMessage(hEdit, WM_GETFONT, 0, 0), True

Bei mehreren Comboboxen retten wir den Font aber lieber in einem Handle (hFont), bevor die Editbox gelöscht wird.
hFont = SendMessage(hEdit, WM_GETFONT, 0, 0) 
SendMessage hWndCB, WM_SETFONT, hFont, True

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 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 GetDlgItem Lib "user32" ( _
        ByVal hDlg As LongPtr, ByVal nIDDlgItem As Long) As LongPtr
Private Declare PtrSafe Function SetWindowTextA Lib "user32" ( _
        ByVal hwnd As LongPtr, ByVal lpString As String) As Long
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 DestroyWindow Lib "user32" (ByVal hwnd As LongPtr) As Long
Private Const WS_CB_MYSTYLE As Long = &H50000302 ' WS_CHILD + WS_VISIBLE + CBS_DROPDOWNLIST + CBS_HASSTRINGS + CBS_SORT
Private Const WS_VSCROLL    As Long = &H200000

Dim mhTimer As LongPtr
Dim msCBElemente() As String, msDefault As String

Private Function InputBoxEx(sMsgTxt As String, sCaption As String, _
                            sCBElemente As String, Optional sDefault As String) As Variant
' Anzeigen einer Inputbox als Combobox
  msCBElemente = Split(sCBElemente, ",")                        ' Range mit Elementen global
  msDefault = sDefault                                          ' Defaulttext global
  mhTimer = SetTimer(0&, 0&, 10, AddressOf ComboBoxHookProc)    ' Timer setzen
  InputBoxEx = InputBox(sMsgTxt, sCaption, sDefault)            ' (Excel)-Inputbox starten
End Function

Private Sub ComboBoxHookProc()
' Setzt die Hooking-Prozedur für die InputBox
  Dim i As Integer, hWndCB As LongPtr, hEdit As LongPtr
  
  KillTimer 0&, mhTimer: mhTimer = 0                            ' Timer löschen
  hEdit = GetDlgItem(GetActiveWindow, 4900) ' Edit_ID           ' Handle  der Editbox

' Combobox erstellen, mit Elementen füllen  und anzeigen
  hWndCB = CreateWindowExA(0&, "Combobox", "", WS_CB_MYSTYLE Or WS_VSCROLL, _
           12, 110, 464, 20, GetActiveWindow, _
           0&, Application.HinstancePtr, 0)
  For i = 0 To UBound(msCBElemente)
' Element zufügen          &H143 = CB_ADDSTRING
      SendMessageA hWndCB, &H143, ByVal CLng(0), ByVal msCBElemente(i)
  Next i
' Schriftart ändern    &H30 = WM_SETFONT         &H31 = WM_GETFONT
  SendMessageA hWndCB, &H30, SendMessageA(hEdit, &H31, 0, 0), True
  DestroyWindow hEdit                                           ' Editbox entfernen
  SetWindowTextA hWndCB, msDefault                              ' Combobox vorbelegen
  SetWindowLongA hWndCB, -12, 4900  ' (-12) = GWL_ID            ' ID setzen
End Sub

' _
 #####################################################################
Sub AufruftestCombobox4()
  MsgBox InputBoxEx("Bitte wähle einen Namen aus!", "Namen auswählen", "Hubert,Anna,Horst,Udo,Uwe,Karl", "Hubert")
End Sub

_________
viele Grüße
Karl-Heinz