Die Community zu .NET und Classic VB.
Menü

VB 5/6-Tipp 0325: ListBox mit Grafiken, ownerdrawn

 von 

Beschreibung 

Eine ListBox ist eine ListBox, daran ist nicht zu rütteln, oder doch? Windows bietet z.B. auch für die ListBox den OwnerDrawn-Modus an. Dadurch ist es möglich jeden Eintrag individuell optisch zu gestalten. Hier anhand des Einfügens von kleinen Grafiken demonstriert. Denkbare Spielarten gibt es sicher viele, z.B. das originale Darstellen der Schriftarten. Wer dazu lustig ist kann dies gerne einmal probieren und einsenden.

Schwierigkeitsgrad:

Schwierigkeitsgrad 3

Verwendete API-Aufrufe:

BitBlt, CallWindowProcA (CallWindowProc), RtlMoveMemory (CopyMemory), CreateSolidBrush, CreateWindowExA (CreateWindowEx), DeleteObject, DestroyWindow, DrawTextExA (DrawTextEx), FillRect, GetSysColor, SendMessageA (SendMessage), SetBkColor, SetTextColor, SetWindowLongA (SetWindowLong)

Download:

Download des Beispielprojektes [7,07 KB]

'Dieser Quellcode stammt von http://www.activevb.de
'und kann frei verwendet werden. Für eventuelle Schäden
'wird nicht gehaftet.

'Um Fehler oder Fragen zu klären, nutzen Sie bitte unser Forum.
'Ansonsten viel Spaß und Erfolg mit diesem Source!

'------------- Anfang Projektdatei Project1.vbp -------------
'--------- Anfang Formular "Form1" alias Form1.frm  ---------
' Steuerelement: Bildfeld-Steuerelement "Picture1" (Index von 0 bis 3)

Option Explicit

Private Sub Form_Load()
  Call InitListBox(Me)
End Sub

Private Sub Form_Unload(Cancel As Integer)
  Call ExitListBox
End Sub
'---------- Ende Formular "Form1" alias Form1.frm  ----------
'--------- Anfang Modul "Module1" alias Module1.bas ---------

Option Explicit

Private Declare Function GetSysColor Lib "user32" (ByVal nIndex _
        As Long) As Long
       
Private Declare Function CreateWindowEx Lib "user32" Alias _
        "CreateWindowExA" (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 Long, ByVal hMenu As Long, ByVal hInstance _
        As Long, lpParam As Any) As Long

Private Declare Function DestroyWindow Lib "user32" (ByVal hWnd _
        As Long) 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 SetWindowLong Lib "user32" Alias _
        "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex _
        As Long, ByVal dwNewLong 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 Sub CopyMemory Lib "KERNEL32" Alias "RtlMoveMemory" _
        (lpDest As Any, lpSource As Any, ByVal nCount As Long)

Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal _
        crColor As Long) As Long

Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject _
        As Long) As Long
    
Private Declare Function SetBkColor Lib "gdi32" (ByVal hDC As Long, _
        ByVal crColor As Long) As Long

Private Declare Function SetTextColor Lib "gdi32" (ByVal hDC As Long, _
        ByVal crColor As Long) As Long

Private Declare Function DrawTextEx Lib "user32" Alias "DrawTextExA" _
        (ByVal hDC As Long, ByVal lpsz As String, ByVal n As Long, _
        lpRect As RECT, ByVal un As Long, lpDrawTextParams As Any) _
        As Long

Private Declare Function BitBlt Lib "gdi32" (ByVal hDCDest As _
        Long, ByVal XDest As Long, ByVal YDest As Long, ByVal _
        nWidth As Long, ByVal nHeight As Long, ByVal hDCSrc _
        As Long, ByVal XSrc As Long, ByVal YSrc As Long, ByVal _
        dwRop As Long) As Long

Private Declare Function FillRect Lib "user32" (ByVal hDC As Long, _
        lpRect As RECT, ByVal hBrush As Long) As Long

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
  itemID As Long
  itemAction As Long
  itemState As Long
  hwndItem As Long
  hDC As Long
  rcItem As RECT
  ItemData As Long
End Type

Private Type DRAWTEXTPARAMS
  cbSize As Long
  iTabLength As Long
  iLeftMargin As Long
  iRightMargin As Long
  uiLengthDrawn As Long
End Type

Const GWL_WNDPROC = (-4&)
Const SRCCopy = &HCC0020

Const COLOR_HIGHLIGHT = &HD
Const COLOR_HIGHLIGHTTEXT = &HE
Const COLOR_BTNTEXT = &H12

Const BDR_RAISEDOUTER = &H1
Const BDR_RAISEDINNER = &H4
Const EDGE_RAISED = (BDR_RAISEDOUTER Or BDR_RAISEDINNER)

Const WS_VSCROLL = &H200000
Const WS_BORDER = &H800000
Const WS_CHILD = &H40000000
Const WS_VISIBLE = &H10000000
Const WS_EX_CLIENTEDGE = &H200&

Const LBS_HASSTRINGS = &H40&
Const LBS_OWNERDRAWFIXED = &H10&
Const LBS_NOINTEGRALHEIGHT = &H100&

Const LB_ADDSTRING = &H180
Const LB_GETTEXT = &H189
Const LB_GETTEXTLEN = &H18A
Const LB_SETITEMHEIGHT = &H1A0

Const ODS_SELECTED = &H1

Const WM_SETFONT = &H30
Const WM_GETFONT = &H31
Const WM_DRAWITEM = &H2B
Const WM_CTLCOLORLISTBOX = &H134
Const WM_LBUTTONDOWN = &H201
Const WM_LBUTTONUP = &H202

Const DT_LEFT = &H0
Const DT_VCENTER = &H4
Const DT_SINGLELINE = &H20

Private Type ODLBTYPE
  Forecolor As Long
  Backcolor As Long
  ForeColorSelected As Long
  BackColorSelected As Long
  BorderStyle As Long
  DrawStyle As Long
  ItemHeight As Long
  hWnd As Long
  Left As Long
  Top  As Long
  Width As Long
  Height As Long
  hFont As Long
  Parent As Form
End Type

Public MyListBox As ODLBTYPE

Dim PrevWndProc&, PrevWndProcLB&

'Subclassing initieren
Private Sub SubClass(hWnd&)
  PrevWndProc = SetWindowLong(hWnd, GWL_WNDPROC, AddressOf WndProc)
  PrevWndProcLB = SetWindowLong(MyListBox.hWnd, GWL_WNDPROC, _
                                AddressOf WndProcLB)
End Sub

'Subclassing Auflösen
Private Sub UnSubClass(hWnd&)
  Call SetWindowLong(hWnd, GWL_WNDPROC, PrevWndProc)
  Call SetWindowLong(MyListBox.hWnd, GWL_WNDPROC, PrevWndProcLB)
End Sub

'Subclassing Routine des Forms für die ReDrawereignisse
Private Function WndProc(ByVal hWnd As Long, ByVal MSG As Long, _
                         ByVal wParam As Long, ByVal lParam As _
                         Long) As Long
                
  Select Case MSG
    Case WM_CTLCOLORLISTBOX: WndProc = MyListBox.DrawStyle
    Case WM_DRAWITEM:        DrawItem (lParam)
                             WndProc = 1
    Case Else:               WndProc = CallWindowProc(PrevWndProc, _
                                                      hWnd, MSG, _
                                                      wParam, _
                                                      lParam)
  End Select
End Function

'Subclassing Routine des ListBox. Hier könnte das Eventhandling
'stattfinden
Private Function WndProcLB(ByVal hWnd As Long, ByVal MSG As Long, _
                           ByVal wParam As Long, ByVal lParam As _
                           Long) As Long
  
  If MSG = WM_LBUTTONDOWN Then Beep
  WndProcLB = CallWindowProc(PrevWndProcLB, hWnd, MSG, _
                             wParam, lParam)
End Function

'Erstellen der neuen ListBox
Public Sub InitListBox(F As Form)
  Dim x&, LStyle&
  
    With MyListBox
      Set .Parent = F
      .Forecolor = GetSysColor(COLOR_BTNTEXT)
      .Backcolor = RGB(255, 255, 255)
      .ForeColorSelected = GetSysColor(COLOR_HIGHLIGHTTEXT)
      .BackColorSelected = GetSysColor(COLOR_HIGHLIGHT)
      .BorderStyle = EDGE_RAISED
          
      .Left = 6
      .Top = 6
      .Width = 167
      .Height = 200
      
      LStyle = LBS_HASSTRINGS Or LBS_OWNERDRAWFIXED Or _
               LBS_NOINTEGRALHEIGHT Or WS_CHILD Or WS_VISIBLE _
               Or WS_BORDER Or WS_VSCROLL

      .hWnd = CreateWindowEx(WS_EX_CLIENTEDGE, "LISTBOX", _
                             vbNullString, LStyle, .Left, _
                             .Top, .Width, .Height, .Parent.hWnd, _
                             0, App.hInstance, ByVal 0&)
                             
      .hFont = SendMessage(.Parent.hWnd, WM_GETFONT, 0&, ByVal 0&)
      Call SendMessage(.hWnd, WM_SETFONT, .hFont, ByVal 1&)
                       
      Call DeleteObject(.hFont)
      
      .ItemHeight = 16
      Call SendMessage(.hWnd, LB_SETITEMHEIGHT, 0&, _
                       ByVal .ItemHeight)
    
      .DrawStyle = CreateSolidBrush(.Backcolor)
      
      For x = 0 To 20
        Call SendMessage(.hWnd, LB_ADDSTRING, -1, _
                         ByVal "Eintrag Nr. " & CStr(x))
      Next x
      
      Call SubClass(.Parent.hWnd)
    End With
End Sub

'Löschen der ListBox aund Aufheben des Subclassings
Public Sub ExitListBox()
  Call DestroyWindow(MyListBox.hWnd)
  Call DeleteObject(MyListBox.DrawStyle)
  UnSubClass (MyListBox.Parent.hWnd)
End Sub

'Zeichnen der jeweilgen ListBox-Einträge
Private Sub DrawItem(lParam&)
  Dim BColor&, FColor&, hBrush&, ItemText$, l&
  Dim DI As DRAWITEMSTRUCT, DTP As DRAWTEXTPARAMS
  
    Call CopyMemory(DI, ByVal lParam, Len(DI))
  
    With DI
      If .itemState And ODS_SELECTED Then
        BColor = SetBkColor(.hDC, MyListBox.BackColorSelected)
        hBrush = CreateSolidBrush(MyListBox.BackColorSelected)
        FColor = SetTextColor(.hDC, MyListBox.ForeColorSelected)
      Else
        BColor = SetBkColor(.hDC, MyListBox.Backcolor)
        hBrush = CreateSolidBrush(MyListBox.Backcolor)
        FColor = SetTextColor(.hDC, MyListBox.Forecolor)
      End If
    
      Call BitBlt(.hDC, .rcItem.Left + 4, .rcItem.Top + 1, 13, 11, _
                  MyListBox.Parent.Picture1(.itemID Mod 4).hDC, 0, _
                  0, SRCCopy)
                  
      .rcItem.Left = .rcItem.Left + 20
      Call FillRect(.hDC, .rcItem, hBrush)
        
      l = SendMessage(MyListBox.hWnd, LB_GETTEXTLEN, _
                      .itemID, ByVal 0&)
                      
      If l > 0 Then
        ItemText = String$(l, vbNullChar)
        Call SendMessage(MyListBox.hWnd, LB_GETTEXT, _
                         .itemID, ByVal ItemText)
      End If
      
      DTP.cbSize = Len(DTP)
      Call DrawTextEx(.hDC, ItemText, Len(ItemText), .rcItem, DT_LEFT _
                      Or DT_VCENTER Or DT_SINGLELINE, DTP)
                      
      Call SetTextColor(.hDC, FColor)
      Call SetBkColor(.hDC, BColor)
    End With
    
    Call DeleteObject(hBrush)
    Call CopyMemory(ByVal lParam, DI, Len(DI))
End Sub
'---------- Ende Modul "Module1" alias Module1.bas ----------
'-------------- Ende Projektdatei Project1.vbp --------------

Tipp-Kompatibilität:

Windows/VB-VersionWin32sWin95Win98WinMEWinNT4Win2000WinXP
VB4
VB5
VB6

Hat dieser Tipp auf Ihrem Betriebsystem und mit Ihrer VB-Version funktioniert?

Ja, funktioniert!

Nein, funktioniert nicht bei mir!

VB-Version:

Windows-Version:

Ihre Meinung  

Falls Sie Fragen zu diesem Artikel haben oder Ihre Erfahrung mit anderen Nutzern austauschen möchten, dann teilen Sie uns diese bitte in einem der unten vorhandenen Themen oder über einen neuen Beitrag mit. Hierzu können sie einfach einen Beitrag in einem zum Thema passenden Forum anlegen, welcher automatisch mit dieser Seite verknüpft wird.

Archivierte Nutzerkommentare 

Klicken Sie diesen Text an, wenn Sie die 5 archivierten Kommentare ansehen möchten.
Diese stammen noch von der Zeit, als es noch keine direkte Forenunterstützung für Fragen und Kommentare zu einzelnen Artikeln gab.
Aus Gründen der Vollständigkeit können Sie sich die ausgeblendeten Kommentare zu diesem Artikel aber gerne weiterhin ansehen.

Kommentar von Friedrich Steinborn am 31.05.2005 um 09:53

Die Sache funktioniert gut! Ich habe sie in einer Anwendung bei mir eingesetzt und habe noch 2 kleine Probleme:
1. Wie kann ich den Font der Listbox auf Courier New, 9 Punkt setzen? (Das Problem von Jürgen vom 20.11.2004 habe ich auch beobachtet!)

2. In meiner Anwendung gibt es keinen vertikalen Scrollbalken (die Daten laufen nach unten aus der Listbox hinaus). Woran kann das liegen?

Kommentar von Jürgen am 20.11.2004 um 13:15

Hallo,

ich habe den Tip eingebaut und er funktioniert auch genau wie beschrieben, hat allerdings einen Fehler:

Ich habe in meinem gesamten Formular den Standart-Font eingestellt. Wenn ich das Projekt starte und die ListBox initialisiere, verwendet er für diese aber eine andere (größere und fettere) Schrift. Außerdem erhalten ALLE Steuerelemente auf dem Forumlar diese andere Schrift!
Wieder in der IDE (nach Ausführung) steht die Font-Eigenschaft aller Steuerelemente auf dem Standart, zeigen aber auch hier die falsche Schriftart an.
Wenn ich dann durch Doppelklick auf die Eigenschaft der Font-Dialog aufrufe und einfach "OK" wähle, zeigt er die Schrift bei diesem Steuerelement wieder richtig an. Bis zum nächsten Start des Projektes......

Hat jemand eine Idee, woher der Fehler kommt, bzw. wie man ihn eliminiert?

Danke
Jürgen

Kommentar von Peter Rundberg am 19.11.2001 um 09:35

Getting the font from the parent does not work. Any ideas of how to solve that?

Kommentar von Dave am 10.11.2001 um 15:23

Hallo
Wahrscheinlich irgend ein banaler Fehler von mir, ich hab auch nicht rumprobiert, aber bei mir heisst es Form1.log nicht gefunden, und VB schmiert ab...

Kommentar von Adam Bagsik am 09.02.2001 um 07:25

Hallo zusammen.
Diese Funktion ist einfach genial.
Ich verwende aber bei meiner ListBox den Click-Event. Dabei wird der Wert der des markierten Feldes herausgelesen. Wie funktioniert es bei dieser ListBox und wie kann man den ListIndex setzten?
MfG
Adam