27.03.2025, 13:50
Liebe Leserin, lieber Leser,
obwohl ich selbst bisher noch keine Listbox im Einsatz hatte, möchte ich heute trotzdem mal das spannnende Thema formatierte Listbox mit Bildern aufgreifen und hier in diesem Workshop einige Beispiele hierzu geben.
Denn die Listbox scheint mir das beliebteste Control zu sein.
Listboxen werden ja meistens in eine Userform eingebettet. Ob hier mit Bordmitteln Bilder hinzugefügt werden können, weiß ich derzeit leider nicht.
Für eine schnelle Auswahl aus einer Listbox ohne Userform bietet sich ohnehin wieder die Einbettung in eine fertige Dialogbox an. Die Wahl fiel wieder auf die Inputbox.
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 der Inputbox eine Listbox hinzu und legen sie über die vorher ausgeblendete Editbox.
Optional können wir die beiden Buttons "OK" und "Abbrechen" nach unten unter die Listbox verschieben, so dass der Platz optiomal genutzt werden kann.
Nach dem Hinzufügen der gewünschten Elemente ist unsere Listboxdialogbox auch schon fertig.
Mit der Auswahl eines Elements wird dessen Text in die Originaleditbox überführt. Damit überlassen wir der Inputbox das Managen der Rückgabe und haben keine Arbeit damit.
Der hier gezeigte bzw. der in der Beispieldatei enthaltene Code zeigt, wie man
Hier ein paar Ansichten:
Achtung: Dieser Beispielcode verwendet die BitMaps aus einem Dateiordner. Es funktioniert daher nur, wenn die in der beigefügten Zip-Datei enthaltenen Dateien in den vorher angelegten Ordner ThisWorkbook.Path & "\Bitmaps\" extrahiert wurden.
Oder Du änderst den Code entsprechend ab.
PS. In der anliegenden Datei findest Du auch noch einige andere Beispiele, von der einfachen codesparenden Minimalversion bis zur mehrfabigen Version mit Multiselect.
Inputbox_Listbox_CEF.xlsb (Größe: 155,5 KB / Downloads: 0)
BitMaps_Flaggen.zip (Größe: 27,07 KB / Downloads: 0)
So, und nun viel Spaß beim Ausprobieren...
obwohl ich selbst bisher noch keine Listbox im Einsatz hatte, möchte ich heute trotzdem mal das spannnende Thema formatierte Listbox mit Bildern aufgreifen und hier in diesem Workshop einige Beispiele hierzu geben.
Denn die Listbox scheint mir das beliebteste Control zu sein.
Listboxen werden ja meistens in eine Userform eingebettet. Ob hier mit Bordmitteln Bilder hinzugefügt werden können, weiß ich derzeit leider nicht.
Für eine schnelle Auswahl aus einer Listbox ohne Userform bietet sich ohnehin wieder die Einbettung in eine fertige Dialogbox an. Die Wahl fiel wieder auf die Inputbox.
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 der Inputbox eine Listbox hinzu und legen sie über die vorher ausgeblendete Editbox.
Optional können wir die beiden Buttons "OK" und "Abbrechen" nach unten unter die Listbox verschieben, so dass der Platz optiomal genutzt werden kann.
Nach dem Hinzufügen der gewünschten Elemente ist unsere Listboxdialogbox auch schon fertig.
Mit der Auswahl eines Elements wird dessen Text in die Originaleditbox überführt. Damit überlassen wir der Inputbox das Managen der Rückgabe und haben keine Arbeit damit.
Der hier gezeigte bzw. der in der Beispieldatei enthaltene Code zeigt, wie man
- eine Listbox in die Inputbox eingebettet
- den Font der Listbox ändern kann
- kleine BitMaps den Elementen hinzufügt
- die Farben des Selektionsbalkens ändern kann
- MultiSelect realisiert und ggf. mehrere Spalten anlegt
- andersfarbige Zwischenüberschriften in fetter Schrift darstellt und die Items aus der Auswahl ausschließt
Hier ein paar Ansichten:
Achtung: Dieser Beispielcode verwendet die BitMaps aus einem Dateiordner. Es funktioniert daher nur, wenn die in der beigefügten Zip-Datei enthaltenen Dateien in den vorher angelegten Ordner ThisWorkbook.Path & "\Bitmaps\" extrahiert wurden.
Oder Du änderst den Code entsprechend ab.
PS. In der anliegenden Datei findest Du auch noch einige andere Beispiele, von der einfachen codesparenden Minimalversion bis zur mehrfabigen Version mit Multiselect.
Inputbox_Listbox_CEF.xlsb (Größe: 155,5 KB / Downloads: 0)
BitMaps_Flaggen.zip (Größe: 27,07 KB / Downloads: 0)
So, und nun viel Spaß beim Ausprobieren...
Code:
Private Const ciHoch As Long = 300 ' Dlg-Höhe
Private Const cx As Long = 18 ' BitMap-Breite
Private Const cy As Long = 12 ' BitMap-Höhe
' GDI-Funktionen
Private Declare PtrSafe Function GetSysColorBrush Lib "user32" ( _
ByVal nIndex As Long) As LongPtr
Private Declare PtrSafe Function GetSysColor Lib "user32" ( _
ByVal nIndex As Long) As Long
' 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 ShowWindow Lib "user32" ( _
ByVal hWnd As LongPtr, ByVal nCmdShow As Long) 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
Private Const WS_LB1 As Long = &H50010000 ' WS_CHILD or WS_VISIBLE or WS_TABSTOP
Private Const WS_LB2 As Long = &HA00000 ' WS_SCROLL + WS_BORDER
Private Const LB_ADDSTRING As Long = &H180
Private Const LB_GETTEXT As Long = &H189
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 Const SWP_NOMOVE As Long = &H2
Private Const SWP_NOSIZE As Long = &H1
' Sub-Classing-Funktionen
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 Const GWL_WNDPROC As Long = (-4)
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 Const WS_LB3 As Long = &H51 ' LBS_NOTIFY + LBS_OWNERDRAWFIXED + LBS_HASSTRINGS
Private Type Rect
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Type DRAWITEMSTRUCT
CtlType As Long
CtlID As Long
Nr As Long ' original itemID
itemAction As Long
itemState As Long
hwndItem As LongPtr
hDC As LongPtr
rcItem As Rect
itemData As LongPtr
End Type
Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
Destination As Any, Source As Any, ByVal Length As LongPtr)
Private Declare PtrSafe Function FillRect Lib "user32" ( _
ByVal hDC As LongPtr, lpRect As Rect, ByVal hBrush As LongPtr) As Long
Private Declare PtrSafe Function SetBkMode Lib "gdi32" ( _
ByVal hDC As LongPtr, ByVal nBkMode As Long) As Long
Private Declare PtrSafe Function SetTextColor Lib "gdi32" ( _
ByVal hDC As LongPtr, ByVal crColor As Long) As Long
Private Declare PtrSafe Function DrawTextA Lib "user32" ( _
ByVal hDC As LongPtr, ByVal lpStr As String, ByVal nCount As Long, _
lpRect As Rect, ByVal wFormat As Long) As Long
Private Declare PtrSafe Function DrawState Lib "user32" Alias "DrawStateA" ( _
ByVal hDC As LongPtr, ByVal hBrush As LongPtr, _
ByVal lpDrawStateProc As LongPtr, _
ByVal lParam As LongPtr, ByVal wParam As LongPtr, _
ByVal n1 As Long, ByVal n2 As Long, _
ByVal n3 As Long, ByVal n4 As Long, ByVal un As Long) As Long
Private Declare PtrSafe Function CreateSolidBrush Lib "gdi32" ( _
ByVal crColor As Long) As LongPtr
Private Declare PtrSafe Function DeleteObject Lib "gdi32" ( _
ByVal hObject As LongPtr) As Long
Private Const LB_SETITEMHEIGHT As Long = &H1A0
' #### Wird nur benötigt, wenn BitMaps aus Datei geladen werden ####
Private Const csPfad As String = "#PATH#\Bitmaps\#.bmp" ' <<<< Pfad ggf. anpassen >>>>
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 Const LB_SETITEMDATA As Long = &H19A
Private Const LB_GETITEMDATA As Long = &H199
Private Const LB_GETCOUNT As Long = &H18B
Dim mhTimer As LongPtr, mlpOldProc As LongPtr
Dim mhLB As LongPtr, mhBmp As LongPtr
Dim msArr() As String
Private Function ListboxEx(sMsgTxt As String, sCaption As String, _
sLBElemente As String, Optional sDefault As String) As Variant
' Anzeigen einer Inputbox als ListBox mit Bildern
msArr = Split(sLBElemente, ",") ' Array mit Elementen global
mhTimer = SetTimer(0&, 0&, 10, AddressOf ListBoxHookProc) ' Timer setzen
ListboxEx = InputBox(sMsgTxt, sCaption, sDefault) ' (Excel)-Inputbox starten
End Function
Private Sub ListBoxHookProc()
' Setzt die Hooking-Prozedur für die Listbox
Dim i As Long, hDlg As LongPtr, sBmpDatei As String
KillTimer 0&, mhTimer: mhTimer = 0 ' Timer löschen
hDlg = GetActiveWindow ' 4900 = Edit_ID ' Handle der Inputbox
ShowWindow GetDlgItem(hDlg, 4900), 0 ' Editbox ausblenden
' Dlg-Größe anpassen und Button verschieben
SetWindowPos hDlg, 0, 0, 0, 510, ciHoch, SWP_NOMOVE ' Dlg-Größe anpassen
' Eine ListBox erstellen, mit Elementen füllen und anzeigen <<<< Maße ggf. anpassen >>>>
mhLB = CreateWindowExA(0&, "Listbox", "", WS_LB1 + WS_LB2 + WS_LB3, _
12, 48, 350, ciHoch - 100, _
hDlg, 0, Application.HinstancePtr, 0&)
' Elemente einfügen
For i = 0 To UBound(msArr)
SendMessageA mhLB, LB_ADDSTRING, 1, ByVal msArr(i) ' Item-Text einsetzen
sBmpDatei = Replace(csPfad, "#PATH#", ThisWorkbook.Path)
sBmpDatei = Replace(sBmpDatei, "#", Split(msArr(i))(0)) ' BMP-Datei ermitteln
' Bitmap laden IMAGE_BITMAP = &H0 &H10 = LR_LOADFROMFILE
mhBmp = LoadImageA(0, ByVal sBmpDatei, &H0, 0, 0, &H10) ' Bitmap aus Datei
If mhBmp <> 0 Then SendMessageA mhLB, LB_SETITEMDATA, i, ByVal mhBmp
Next i
' Inputbox hooken
mlpOldProc = SetWindowLongA(hDlg, GWL_WNDPROC, 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 bSel As Boolean, i As Long, l As Long, R As Rect
Dim sText As String * 255
Dim tDrawItemSet As DRAWITEMSTRUCT
With tDrawItemSet
' .hwndItem entspricht dem LB-Handle, hwnd entspricht dem Dlg-Handle
Select Case uMsg
Case &H2B ' WM_DRAWITEM
CopyMemory tDrawItemSet, ByVal lParam, LenB(tDrawItemSet) ' Pointer in Struktur kopieren
If .Nr = &HFFFFFFFF Then Exit Function ' Liste ist leer =>raus
R = .rcItem
SendMessageA .hwndItem, LB_GETTEXT, .Nr, ByVal sText ' Item-Text holen
bSel = (.itemState And 1) ' 1 = ODS_SELECTED
If bSel Then SetWindowTextA GetDlgItem(hWnd, 4900), sText ' Editbox mit selektiertem Item updaten
' 5=COLOR_WINDOW, 13=COLOR_HIGHLIGHT, 8=COLOR_WINDOWTEXT, 14=COLOR_HIGHLIGHTTEXT
FillRect .hDC, R, GetSysColorBrush(IIf(bSel, 13, 5)) ' Hintergrund zeichnen
SetBkMode .hDC, 1 ' Hintergrund auf TRANSPARENT = 1 setzen
SetTextColor .hDC, GetSysColor(IIf(bSel, 14, 8)) ' Schriftfarbe setzen
R.Left = cx + 10 ' &H24 = DT_SINGLELINE + DT_LEFT + DT_VCENTER
DrawTextA .hDC, sText, 255, R, &H24 ' Text schreiben
' BitMap: Handle holen und zeichnen,
mhBmp = SendMessageA(.hwndItem, LB_GETITEMDATA, .Nr, ByVal 0)
DrawState .hDC, 0, 0, mhBmp, 0, 3, R.Top + 4, 0, 0, &H4 ' &H4 = DST_BITMAP
Case &H2 ' WM_DESTROY
For i = 0 To CLng(SendMessageA(mhLB, LB_GETCOUNT, 0, 0)) - 1
mhBmp = SendMessageA(mhLB, LB_GETITEMDATA, i, ByVal 0) ' BitMap-Handle holen
DeleteObject mhBmp ' BitMap-Handle löschen
Next i
SetWindowLongA hWnd, GWL_WNDPROC, mlpOldProc ' InputBox unhooken
End Select
End With
WindowProc = CallWindowProcA(mlpOldProc, hWnd, uMsg, wParam, ByVal lParam) ' Andere Messages weiterleiten
End Function
' #####################################################################
Sub AufrufListboxCEF()
MsgBox ListboxEx("Bitte wähle ein Land aus!", "Land auswählen", _
"Dänemark,Deutschland,England,Island,Italien,Niederlande,Norwegen,Portugal,Schweden", 2)
End Sub
Private Const cx As Long = 18 ' BitMap-Breite
Private Const cy As Long = 12 ' BitMap-Höhe
' GDI-Funktionen
Private Declare PtrSafe Function GetSysColorBrush Lib "user32" ( _
ByVal nIndex As Long) As LongPtr
Private Declare PtrSafe Function GetSysColor Lib "user32" ( _
ByVal nIndex As Long) As Long
' 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 ShowWindow Lib "user32" ( _
ByVal hWnd As LongPtr, ByVal nCmdShow As Long) 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
Private Const WS_LB1 As Long = &H50010000 ' WS_CHILD or WS_VISIBLE or WS_TABSTOP
Private Const WS_LB2 As Long = &HA00000 ' WS_SCROLL + WS_BORDER
Private Const LB_ADDSTRING As Long = &H180
Private Const LB_GETTEXT As Long = &H189
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 Const SWP_NOMOVE As Long = &H2
Private Const SWP_NOSIZE As Long = &H1
' Sub-Classing-Funktionen
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 Const GWL_WNDPROC As Long = (-4)
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 Const WS_LB3 As Long = &H51 ' LBS_NOTIFY + LBS_OWNERDRAWFIXED + LBS_HASSTRINGS
Private Type Rect
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Type DRAWITEMSTRUCT
CtlType As Long
CtlID As Long
Nr As Long ' original itemID
itemAction As Long
itemState As Long
hwndItem As LongPtr
hDC As LongPtr
rcItem As Rect
itemData As LongPtr
End Type
Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
Destination As Any, Source As Any, ByVal Length As LongPtr)
Private Declare PtrSafe Function FillRect Lib "user32" ( _
ByVal hDC As LongPtr, lpRect As Rect, ByVal hBrush As LongPtr) As Long
Private Declare PtrSafe Function SetBkMode Lib "gdi32" ( _
ByVal hDC As LongPtr, ByVal nBkMode As Long) As Long
Private Declare PtrSafe Function SetTextColor Lib "gdi32" ( _
ByVal hDC As LongPtr, ByVal crColor As Long) As Long
Private Declare PtrSafe Function DrawTextA Lib "user32" ( _
ByVal hDC As LongPtr, ByVal lpStr As String, ByVal nCount As Long, _
lpRect As Rect, ByVal wFormat As Long) As Long
Private Declare PtrSafe Function DrawState Lib "user32" Alias "DrawStateA" ( _
ByVal hDC As LongPtr, ByVal hBrush As LongPtr, _
ByVal lpDrawStateProc As LongPtr, _
ByVal lParam As LongPtr, ByVal wParam As LongPtr, _
ByVal n1 As Long, ByVal n2 As Long, _
ByVal n3 As Long, ByVal n4 As Long, ByVal un As Long) As Long
Private Declare PtrSafe Function CreateSolidBrush Lib "gdi32" ( _
ByVal crColor As Long) As LongPtr
Private Declare PtrSafe Function DeleteObject Lib "gdi32" ( _
ByVal hObject As LongPtr) As Long
Private Const LB_SETITEMHEIGHT As Long = &H1A0
' #### Wird nur benötigt, wenn BitMaps aus Datei geladen werden ####
Private Const csPfad As String = "#PATH#\Bitmaps\#.bmp" ' <<<< Pfad ggf. anpassen >>>>
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 Const LB_SETITEMDATA As Long = &H19A
Private Const LB_GETITEMDATA As Long = &H199
Private Const LB_GETCOUNT As Long = &H18B
Dim mhTimer As LongPtr, mlpOldProc As LongPtr
Dim mhLB As LongPtr, mhBmp As LongPtr
Dim msArr() As String
Private Function ListboxEx(sMsgTxt As String, sCaption As String, _
sLBElemente As String, Optional sDefault As String) As Variant
' Anzeigen einer Inputbox als ListBox mit Bildern
msArr = Split(sLBElemente, ",") ' Array mit Elementen global
mhTimer = SetTimer(0&, 0&, 10, AddressOf ListBoxHookProc) ' Timer setzen
ListboxEx = InputBox(sMsgTxt, sCaption, sDefault) ' (Excel)-Inputbox starten
End Function
Private Sub ListBoxHookProc()
' Setzt die Hooking-Prozedur für die Listbox
Dim i As Long, hDlg As LongPtr, sBmpDatei As String
KillTimer 0&, mhTimer: mhTimer = 0 ' Timer löschen
hDlg = GetActiveWindow ' 4900 = Edit_ID ' Handle der Inputbox
ShowWindow GetDlgItem(hDlg, 4900), 0 ' Editbox ausblenden
' Dlg-Größe anpassen und Button verschieben
SetWindowPos hDlg, 0, 0, 0, 510, ciHoch, SWP_NOMOVE ' Dlg-Größe anpassen
' Eine ListBox erstellen, mit Elementen füllen und anzeigen <<<< Maße ggf. anpassen >>>>
mhLB = CreateWindowExA(0&, "Listbox", "", WS_LB1 + WS_LB2 + WS_LB3, _
12, 48, 350, ciHoch - 100, _
hDlg, 0, Application.HinstancePtr, 0&)
' Elemente einfügen
For i = 0 To UBound(msArr)
SendMessageA mhLB, LB_ADDSTRING, 1, ByVal msArr(i) ' Item-Text einsetzen
sBmpDatei = Replace(csPfad, "#PATH#", ThisWorkbook.Path)
sBmpDatei = Replace(sBmpDatei, "#", Split(msArr(i))(0)) ' BMP-Datei ermitteln
' Bitmap laden IMAGE_BITMAP = &H0 &H10 = LR_LOADFROMFILE
mhBmp = LoadImageA(0, ByVal sBmpDatei, &H0, 0, 0, &H10) ' Bitmap aus Datei
If mhBmp <> 0 Then SendMessageA mhLB, LB_SETITEMDATA, i, ByVal mhBmp
Next i
' Inputbox hooken
mlpOldProc = SetWindowLongA(hDlg, GWL_WNDPROC, 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 bSel As Boolean, i As Long, l As Long, R As Rect
Dim sText As String * 255
Dim tDrawItemSet As DRAWITEMSTRUCT
With tDrawItemSet
' .hwndItem entspricht dem LB-Handle, hwnd entspricht dem Dlg-Handle
Select Case uMsg
Case &H2B ' WM_DRAWITEM
CopyMemory tDrawItemSet, ByVal lParam, LenB(tDrawItemSet) ' Pointer in Struktur kopieren
If .Nr = &HFFFFFFFF Then Exit Function ' Liste ist leer =>raus
R = .rcItem
SendMessageA .hwndItem, LB_GETTEXT, .Nr, ByVal sText ' Item-Text holen
bSel = (.itemState And 1) ' 1 = ODS_SELECTED
If bSel Then SetWindowTextA GetDlgItem(hWnd, 4900), sText ' Editbox mit selektiertem Item updaten
' 5=COLOR_WINDOW, 13=COLOR_HIGHLIGHT, 8=COLOR_WINDOWTEXT, 14=COLOR_HIGHLIGHTTEXT
FillRect .hDC, R, GetSysColorBrush(IIf(bSel, 13, 5)) ' Hintergrund zeichnen
SetBkMode .hDC, 1 ' Hintergrund auf TRANSPARENT = 1 setzen
SetTextColor .hDC, GetSysColor(IIf(bSel, 14, 8)) ' Schriftfarbe setzen
R.Left = cx + 10 ' &H24 = DT_SINGLELINE + DT_LEFT + DT_VCENTER
DrawTextA .hDC, sText, 255, R, &H24 ' Text schreiben
' BitMap: Handle holen und zeichnen,
mhBmp = SendMessageA(.hwndItem, LB_GETITEMDATA, .Nr, ByVal 0)
DrawState .hDC, 0, 0, mhBmp, 0, 3, R.Top + 4, 0, 0, &H4 ' &H4 = DST_BITMAP
Case &H2 ' WM_DESTROY
For i = 0 To CLng(SendMessageA(mhLB, LB_GETCOUNT, 0, 0)) - 1
mhBmp = SendMessageA(mhLB, LB_GETITEMDATA, i, ByVal 0) ' BitMap-Handle holen
DeleteObject mhBmp ' BitMap-Handle löschen
Next i
SetWindowLongA hWnd, GWL_WNDPROC, mlpOldProc ' InputBox unhooken
End Select
End With
WindowProc = CallWindowProcA(mlpOldProc, hWnd, uMsg, wParam, ByVal lParam) ' Andere Messages weiterleiten
End Function
' #####################################################################
Sub AufrufListboxCEF()
MsgBox ListboxEx("Bitte wähle ein Land aus!", "Land auswählen", _
"Dänemark,Deutschland,England,Island,Italien,Niederlande,Norwegen,Portugal,Schweden", 2)
End Sub
_________
viele Grüße
Karl-Heinz
viele Grüße
Karl-Heinz