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 Long, ByVal fEnable As Long) As Long
'OD_DrawListBox
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 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 BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Declare Function TextOut Lib "gdi32" Alias "TextOutA" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal lpString As String, ByVal nCount As Long) As Long
'general use
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (hpvDest As Any, hpvSource As Any, ByVal 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 Object, ByVal ListBoxName As String, ByRef 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 String, ByRef 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 Object, ByVal ControlName As String, ByRef 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]