ComboBoxEx32 - externe Combobox mit Bilder

[volti]

Liebe Leserin, lieber Leser,

bei der Auswahl eines Eintrages aus einer ComboBox wäre manchmal ein zusätzliches Entscheidungskriterium in Form eines erklärendes Bildes schön.

Zur Realisierung so eines Vorhabens gibt es ja u.a. die Klasse ComboboxEx32.

Hier mal ein Beispiel, wie man so eine ComboBoxEx32 z.B. in ein Fenster (hier die Inputbox) einbauen kann.

Im hier gezeigten Code wird die gesamte Inputbox "gekapert", um die gemachte Selektion zurückzugeben.
Die Bilder werden aus einem Verzeichnis geladen.

In der anliegenden Datei sind noch zwei etwas abweichende Varianten enthalten. Ein Beispiel zeigt, wie man die Bilder auch im Excelblatt vorhalten kann.

Letztendlich können hier aber nicht alle möglichen Variationen gezeigt werden....

   


  Inputbox_ComboBoxEx32_CEF.xlsb (Größe: 99,22 KB / Downloads: 5)

Code:

' InputBox-Hooking, Elemente aus String, nur Bitmaps aus Dateien
Option Explicit

Private Const ciMaxItems As Long = 15                        ' Maximal anzuzeigende Items/Zeilen

' Timer-Funktionen
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

' Window-Funktionen
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 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 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 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 ShowWindow Lib "user32" ( _
        ByVal hwnd As LongPtr, ByVal nCmdShow As Long) As Long

' ComboBoxEx- und ImageList-Funktionen
Private Type COMBOBOXEXITEM
   mask           As LongPtr
   iItem          As Long
   pszText        As String
   cchTextMax     As Long
   iImage         As Long
   iSelectedImage As Long
   iOverlay       As Long
   iIndent        As Long
   lParam         As LongPtr
End Type

Private Declare PtrSafe Function InitCommonControlsEx Lib "COMCTL32" ( _
        lpInitCtrls As INITCOMMONCONTROLS_STRUCT) As Long

Private Type INITCOMMONCONTROLS_STRUCT
  dwSize As Long
  dwICC As Long
End Type
Dim CCInit As INITCOMMONCONTROLS_STRUCT

Private Declare PtrSafe Function ImageList_Create Lib "COMCTL32" ( _
        ByVal MinCx As Long, ByVal MinCy As Long, _
        ByVal flags As Long, ByVal cInitial As Long, _
        ByVal cGrow As Long) As LongPtr
Private Declare PtrSafe Function ImageList_Add Lib "COMCTL32" ( _
        ByVal himl As LongPtr, ByVal hbmImage As LongPtr, _
        ByVal hbmMask As LongPtr) As Long
Private Declare PtrSafe Function ImageList_Destroy Lib "COMCTL32" ( _
        ByVal himl As LongPtr) As Long
Private Declare PtrSafe Function LoadImageA Lib "user32" ( _
        ByVal hInst As LongPtr, ByVal lpsz As String, ByVal un1 As Long, _
        ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As LongPtr
        
Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
        
Dim mhImgList As LongPtr, mhDlg As LongPtr, mlpOldProc  As LongPtr
Dim mhWndEdit As LongPtr, mhCBE As LongPtr, mhTimer     As LongPtr
Dim miDefault As String, msPfad As String, msItems() As String

Private Function InputBoxEx(sMsgTxt As String, sCaption As String, _
                            sCBElemente As String, Optional iDefault As Long) As Variant
' Anzeigen einer Inputbox als ComboboxEx mit Bildern
  
  msPfad = ThisWorkbook.Path & "\Bitmaps\#.bmp"                             ' Bilderpfad <<< gf. anpassen >>>
  
  msItems = Split("," & sCBElemente, ",")                                   ' Range mit Elementen global
  miDefault = iDefault                                                      ' Default-Item global machen
  mhTimer = SetTimer(0&, 0&, 10, AddressOf ComboBoxExHookProc)              ' Timer setzen
  InputBoxEx = InputBox(sMsgTxt, sCaption, "")                              ' (Excel)-Inputbox starten
  If mhImgList <> 0 Then ImageList_Destroy mhImgList                        ' ImageListe löschen
  mhImgList = 0
End Function


Private Sub ComboBoxExHookProc()
' Setzt die Hooking-Prozedur für die ComboBoxEx
  Dim i As Integer, iItemAnz As Long, sArr() As String, sBmpDatei As String
  Dim hBmp As LongPtr, iImage As Long, cx As Long, cy As Long, iHoehe As Long
  Dim cbI  As COMBOBOXEXITEM
  Const WS_CBE_STYLE As Long = &H50010003    ' WS_CHILD + WS_VISIBLE + CBS_DROPDOWNLIST + WS_TABSTOP
  
  KillTimer 0&, mhTimer: mhTimer = 0                                        ' Timer löschen
 
  mhDlg = GetActiveWindow                                                   ' Handle der Inputbox
  mhWndEdit = GetDlgItem(mhDlg, 4900)  ' 4900 = Edit_ID                     ' Handle der Editbox
  ShowWindow mhWndEdit, 0                                                   ' Editbox ausblenden

  With CCInit                                                               ' ComboboxEx-Klasse zuweisen
     .dwSize = LenB(CCInit)
     .dwICC = &H200         ' &H200 = ICC_COMBOEX_CLASSES
  End With
  If InitCommonControlsEx(CCInit) = 0 Then Exit Sub                         ' ComboBoxEx registrieren

  iItemAnz = UBound(msItems)
  If iItemAnz > ciMaxItems Then iItemAnz = ciMaxItems

' Eine ComboboxEx erstellen, mit Elementen füllen  und anzeigen

' <<<< Hier die BitMap-Größe der Bilder und Höhe der CB32 einstellen >>>>
  cx = 18: cy = 12: iHoehe = iItemAnz * ((cy + 2) * 2 + 1)
  
' <<<< Hier die Position und Größe der ComboBoxEx einstellen >>>>
  mhCBE = CreateWindowExA(0&, "ComboboxEx32", "", WS_CBE_STYLE, _
                          14, 105, 460, iHoehe, _
                          mhDlg, 0, Application.HinstancePtr, 0&)
  
  mhImgList = ImageList_Create(cx, cy, &H0, 1, 0) ' &H0 = ILC_COLOR         ' Image-Liste erstellen
  SendMessageA mhCBE, &H402, 0, ByVal (mhImgList)  ' &H402 = CBEM_SETIMAGELIST ' Image-Liste setzen
      
' Elemente einfügen
  On Error Resume Next
  For i = 1 To UBound(msItems)
      sBmpDatei = Replace(msPfad, "#", Left$(msItems(i), 3))                ' BMP-Datei ermitteln
' Bitmap laden               IMAGE_BITMAP = &H0        &H10 = LR_LOADFROMFILE
      hBmp = LoadImageA(0, ByVal sBmpDatei, &H0, 0, 0, &H10)

      If hBmp <> 0 Then
         cbI.mask = &H7   ' CBEIF_TEXT + CBEIF_IMAGE + CBEIF_SELECTEDIMAGE
         iImage = ImageList_Add(mhImgList, hBmp, 0)                         ' Bitmap in Image-Liste
         If msPfad & " " Like "*:*" Then DeleteObject hBmp                  ' Bitmap ggf. wieder löschen
       Else
         cbI.mask = &H1   ' CBEIF_TEXT
         iImage = 0
       End If
      
       cbI.pszText = msItems(i)                                             ' Text übernehmen
       cbI.cchTextMax = Len(msItems(i))
       cbI.iImage = iImage
       cbI.iSelectedImage = iImage
       cbI.iItem = -1
' Item einfügen                 &H401 = WM_USER + 1 = CBEM_INSERTITEM
       Call SendMessageA(mhCBE, &H401, 0, cbI)

  Next i
  On Error GoTo 0
  miDefault = IIf(miDefault < 1 Or miDefault >= iItemAnz, 1, miDefault)     ' Defaultselektion korrigieren
  SendMessageA mhCBE, &H14E, miDefault - 1, ByVal 0 ' &H14E = CB_SETCURSEL  ' Item selektieren
  SetWindowTextA mhWndEdit, msItems(miDefault)                              ' Editbox damit updaten

' InputBox hooken                    -4 = GWL_WNDPROC
  mlpOldProc = SetWindowLongA(mhDlg, -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
  
' Hier die Message WM_COMMAND (&H111) für den OK-Button (ID=1) rausfischen und die Editbox updaten
  If uMsg = &H111 And wParam = 1 Then                         ' &H14E = CB_SETCURSEL
     SetWindowTextA mhWndEdit, msItems(CLng(SendMessageA(mhCBE, &H147, 0, 0)) + 1)
  End If
  WindowProc = CallWindowProcA(mlpOldProc, hwnd, uMsg, wParam, ByVal lParam) ' Andere Messages weiterleiten
End Function


' #####################################################################
Sub AufruftestComboboxEx2()
  MsgBox InputBoxEx("Bitte wähle ein Land aus!", "Land auswählen", "Deutschland,England,Frankreich,Island,Italien,Kanada,Norwegen,Portugal,Spanien", 3)
End Sub

_________
viele Grüße
Karl-Heinz

[volti]

Hallo,

ein Update....

Für die Beispiele, bei denen die Dateien aus einem Ordner geladen werden, werden die Flaggen-Dateien im im Code angegebenen Ordner "ThisWorkbook.Path & "\Bitmaps\" erwartet.
Hierzu bitte diesen Ordner anlegen und die BMP-Dateien aus der ZIP-Datei dorthin extrahieren.

In der Beispieldatei ist für die Beispiele "Bilder aus Excel" die Ordnerangabe im Code zu deaktivieren, ansonsten werden die ggf. nicht vorhandenen BMP-Dateien verwendet und keine Flaggen gezeigt.
Deshalb hier noch mal ein Update....


  BitMaps_Flaggen.zip (Größe: 2,75 KB / Downloads: 1)

  Inputbox_ComboBoxEx32_CEF.xlsb (Größe: 93,7 KB / Downloads: 1)

Gruß Karl-Heinz