GFOwnerDraw/GFOwnerDrawmod.bas

Attribute VB_Name = "GFOwnerDrawmod"
Option Explicit
'(c)2002 by Louis.
'
'THIS PROJECT IS NOT FINISHED YET.
'
'NOTE: the whole code was stolen from Matt Hart and manipulated so that it
'looks like I programmed it (whuhahahah).
'
'NOTE: to display icons in a ListBox the following steps
'must be done by the target project:
'‑Call GFOwnerDraw_ReceiveListBox(),
' a reference to a picture box containing the icon to display must be passed,
' the ListBox passed must have set the Style property to 1 (check boxes).
' Several ListBoxes can use one icon picture box.
' The ListBox should not use color 'placeholders' but real colors 'created' by RGB().
'‑Call GFOwnerDraw_ChangeIconPicture() to change the icon instantly.
'
'GFOwnerDraw_ChangeIconPicture
Private Declare Function EnableWindow Lib "user32" (ByVal hwnd As LongByVal fEnable As Long) As Long
'OD_DrawListBox
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As LongByVal wMsg As LongByVal wParam As Long, lParam As Any) As Long
Private Declare Function SetBkColor Lib "gdi32" (ByVal hdc As LongByVal crColor As Long) As Long
Private Declare Function SetTextColor Lib "gdi32" (ByVal hdc As LongByVal crColor As Long) As Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As LongByVal x As LongByVal y As LongByVal nWidth As LongByVal nHeight As LongByVal hSrcDC As LongByVal xSrc As LongByVal ySrc As LongByVal dwRop As Long) As Long
Private Declare Function TextOut Lib "gdi32" Alias "TextOutA" (ByVal hdc As LongByVal x As LongByVal y As LongByVal lpString As StringByVal nCount As Long) As Long
'general use
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (hpvDest As Any, hpvSource As AnyByVal cbCopy As Long)
'OD_DrawListBox (owner draw states)
Const ODS_SELECTED = &H1
Const ODS_GRAYED = &H2
Const ODS_DISABLED = &H4
Const ODS_CHECKED = &H8
Const ODS_FOCUS = &H10
Const ODS_DEFAULT = &H20
Const ODS_COMBOBOXEDIT = &H1000
Const ODS_HOTLIGHT = &H40
Const ODS_INACTIVE = &H80
'OD_DrawListBox
Const LB_GETTEXT = &H189
'OD_DrawListBox
Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type
'OD_DrawListBox
Public Type DRAWITEMSTRUCT 'must be public
    CtlType As Long
    CtlID As Long
    itemID As Long
    itemAction As Long
    itemState As Long
    hwndItem As Long
    IconPicturehdc As Long
    rcItem As RECT
    itemData As Long
End Type
'ODStruct
Private Type ODStruct
    ControlObject As Object
    ControlName As String
    ControlNameLength As Long
    ControlIconPicture As PictureBox
End Type
Dim ODStructNumber As Integer
Dim ODStructArray() As ODStruct

'************************************INTERFACE SUBS*************************************
'NOTE: the following subs/functions are to be used by the target project.

Public Sub GFOwnerDraw_ReceiveListBox(ByRef ListBoxControl As ObjectByVal ListBoxName As StringByRef ListBoxIconPicture As PictureBox)
    'on error resume next
    Dim ControlStructIndex As Integer
    'begin
    If GetODStructIndex(ListBoxName) = 0 Then 'verify
        'NOTE: we register the current control for processing.
        Call ODStruct_AddItem(ListBoxControl, ListBoxName, ListBoxIconPicture)
        'NOTE: we subclass the parent of the list box but use the list box's name.
        Call GFSubClass( _
            Nothing, ListBoxName, GFOwnerDrawfrm, True, _
            GFSubClass_GetParent(ListBoxControl.hwnd))
    End If
End Sub

Public Sub GFOwnerDraw_ChangeIconPicture(ByVal ControlName As StringByRef ControlIconPictureNew As PictureBox)
    'on error resume next
    Dim ControlStructIndex As Integer
    'begin
    ControlStructIndex = GetODStructIndex(ControlName)
    If (ControlStructIndex) Then 'verify
        Set ODStructArray(ControlStructIndex).ControlIconPicture = ControlIconPictureNew
        If ODStructArray(ControlStructIndex).ControlObject.Enabled = True Then
            'NOTE: UpdateWindow() failed (damn it!).
            Call EnableWindow(ODStructArray(ControlStructIndex).ControlObject.hwnd, 0&)
            Call EnableWindow(ODStructArray(ControlStructIndex).ControlObject.hwnd, 1&)
        Else
            Call EnableWindow(ODStructArray(ControlStructIndex).ControlObject.hwnd, 1&)
            Call EnableWindow(ODStructArray(ControlStructIndex).ControlObject.hwnd, 0&)
        End If
    End If
End Sub

'*********************************END OF INTERFACE SUBS*********************************
'*****************************GFOWNERDRAWFRM INTERFACE SUBS*****************************
'NOTE: the following subs/functions are to be used by GFOwnerDrawfrm.
'The target project needn't to use any of the following subs/functions.

Public Function GetODStructIndex(ByRef ControlName As String) As Integer
    'on error resume next 'this function is to be used by GFOwnerDrawfrm only
    Dim ControlNameLength As Long
    Dim StructLoop As Integer
    'preset
    ControlNameLength = Len(ControlName)
    'begin
    For StructLoop = 1 To ODStructNumber
        If ODStructArray(StructLoop).ControlNameLength = ControlNameLength Then 'check first to increase speed
            If ODStructArray(StructLoop).ControlName = ControlName Then
                GetODStructIndex = StructLoop 'ok
                Exit Function
            End If
        End If
    Next StructLoop
    GetODStructIndex = 0 'error
    Exit Function
End Function

Public Sub OD_DrawListBox(ByRef DRAWITEMSTRUCTVar As DRAWITEMSTRUCT, ByVal ControlStructIndex As Integer)
    'on error resume next
    Dim IconXSize As Long
    Dim IconYSize As Long
    Dim IconXPos As Long
    Dim IconYPos As Long
    Dim Text As String
    Dim TextLength As Long
    Dim TextHeight As Long
    'begin
    '
    Text = String$(32767, Chr$(0))
    TextLength = SendMessage(DRAWITEMSTRUCTVar.hwndItem, LB_GETTEXT, DRAWITEMSTRUCTVar.itemID, ByVal Text)
    Text = Left$(Text, TextLength)
    '
    If (ODStructArray(ControlStructIndex).ControlObject.Selected(DRAWITEMSTRUCTVar.itemID) = True) Or _
        (ODStructArray(ControlStructIndex).ControlObject.ListIndex = DRAWITEMSTRUCTVar.itemID) Then
        '
        If ODStructArray(ControlStructIndex).ControlObject.ListIndex = DRAWITEMSTRUCTVar.itemID Then
            Call SetBkColor(DRAWITEMSTRUCTVar.IconPicturehdc, GFGetSystemColor(COLOR_HIGHLIGHTTEXT))
            Call SetTextColor(DRAWITEMSTRUCTVar.IconPicturehdc, GFGetSystemColor(COLOR_HIGHLIGHT))
        Else
            Call SetBkColor(DRAWITEMSTRUCTVar.IconPicturehdc, GFGetSystemColor(COLOR_HIGHLIGHT))
            Call SetTextColor(DRAWITEMSTRUCTVar.IconPicturehdc, GFGetSystemColor(COLOR_HIGHLIGHTTEXT))
        End If
        '
    Else
        Call SetBkColor(DRAWITEMSTRUCTVar.IconPicturehdc, _
            ODStructArray(ControlStructIndex).ControlObject.BackColor)  'GFGetSystemColor(COLOR_WINDOW))
        Call SetTextColor(DRAWITEMSTRUCTVar.IconPicturehdc, _
            ODStructArray(ControlStructIndex).ControlObject.ForeColor) 'GFGetSystemColor(COLOR_WINDOWTEXT))
    End If
    '
    'NOTE: DRAWITEMSTRUCTVar.rcItem is the area where we have to
    'perform the drawing of the icon and also of the text.
    '
    IconXSize = ODStructArray(ControlStructIndex).ControlIconPicture.Width / Screen.TwipsPerPixelX ‑ 4 '4 pixels for borders
    IconYSize = ODStructArray(ControlStructIndex).ControlIconPicture.Height / Screen.TwipsPerPixelY ‑ 4 '4 pixels for borders
    '
    IconXPos = DRAWITEMSTRUCTVar.rcItem.Left
    IconYPos = DRAWITEMSTRUCTVar.rcItem.Top + ((DRAWITEMSTRUCTVar.rcItem.Bottom ‑ DRAWITEMSTRUCTVar.rcItem.Top) / 2&) ‑ (IconYSize / 2&)
    '
    Call BitBlt(DRAWITEMSTRUCTVar.IconPicturehdc, IconXPos, IconYPos, IconXSize, IconYSize, _
        ODStructArray(ControlStructIndex).ControlIconPicture.hdc, 0, 0, vbSrcCopy)
    Call TextOut(DRAWITEMSTRUCTVar.IconPicturehdc, IconXPos + IconXSize, DRAWITEMSTRUCTVar.rcItem.Top, Text, TextLength)
    '
End Sub

'*************************END OF GFOWNERDRAWFRM INTERFACE SUBS**************************
'*****************************************OTHER*****************************************

Private Sub ODStruct_AddItem(ByRef ControlObject As ObjectByVal ControlName As StringByRef ControlIconPicture As PictureBox)
    'on error resume next
    If Not (ODStructNumber = 32766) Then 'verify
        ODStructNumber = ODStructNumber + 1
        ReDim Preserve ODStructArray(1 To ODStructNumber) As ODStruct
        Set ODStructArray(ODStructNumber).ControlObject = ControlObject
        ODStructArray(ODStructNumber).ControlName = ControlName
        ODStructArray(ODStructNumber).ControlNameLength = Len(ControlName)
        Set ODStructArray(ODStructNumber).ControlIconPicture = ControlIconPicture
    Else
        MsgBox "internal error in ODStruct_AddItem(): overflow !", vbOKOnly + vbExclamation
    End If
End Sub


[END OF FILE]