Die Community zu .NET und Classic VB.

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

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

 von ActiveVB

Schwierigkeitsgrad:

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 --------------

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.