Find all our projects in development below.
All source code is GNU General Public License (GPL)
Browsing ListViewParentSubClassMod.bas (13.01 KB)
Attribute VB_Name = "ListViewParentSubClassMod"
Option Explicit
Private Const GWL_WNDPROC = (-4)
Private Const WM_NOTIFY = &H4E
Private Const LVM_FIRST = &H1000
Private Const LVM_GETITEMRECT = (LVM_FIRST + 14)
Private Const LVM_GETSUBITEMRECT = (LVM_FIRST + 56)
Private Const DT_MODIFYSTRING = &H10000
Private Const DT_VCENTER = &H4
Private Const DT_WORD_ELLIPSIS = &H40000
Private Const COLOR_HIGHLIGHT = 13
Private Const COLOR_INACTIVEBORDER = 11
Private Q3ColorArray(9) As Long
Private Const NM_FIRST = -0&
Private Const NM_CUSTOMDRAW = (NM_FIRST - 12)
Private Type NMHDR
hWndFrom As Long
idfrom As Long
code As Long
End Type
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Type NMCUSTOMDRAW
hdr As NMHDR
dwDrawStage As CD_DrawStage
hDC As Long
rc As RECT
dwItemSpec As Long
uItemState As CD_ItemState
lItemlParam As Long
End Type
Private Type NMLVCUSTOMDRAW
nmcd As NMCUSTOMDRAW
clrText As Long
clrTextBk As Long
iSubItem As Long
End Type
Private Enum CD_DrawStage
CDDS_PREPAINT = &H1
CDDS_POSTPAINT = &H2
CDDS_PREERASE = &H3
CDDS_POSTERASE = &H4
CDDS_ITEM = &H10000
CDDS_ITEMPREPAINT = (CDDS_ITEM Or CDDS_PREPAINT)
CDDS_ITEMPOSTPAINT = (CDDS_ITEM Or CDDS_POSTPAINT)
CDDS_ITEMPREERASE = (CDDS_ITEM Or CDDS_PREERASE)
CDDS_ITEMPOSTERASE = (CDDS_ITEM Or CDDS_POSTERASE)
CDDS_SUBITEM = &H20000
End Enum
Private Enum CD_ItemState
CDIS_SELECTED = &H1
CDIS_GRAYED = &H2
CDIS_DISABLED = &H4
CDIS_CHECKED = &H8
CDIS_FOCUS = &H10
CDIS_DEFAULT = &H20
CDIS_HOT = &H40
CDIS_MARKED = &H80
CDIS_INDETERMINATE = &H100
End Enum
Private Enum CD_ReturnFlags
CDRF_DODEFAULT = &H0
CDRF_NOTIFYPOSTPAINT = &H10
CDRF_NOTIFYITEMDRAW = &H20
CDRF_NOTIFYPOSTERASE = &H40
CDRF_NOTIFYITEMERASE = &H80
CDRF_NEWFONT = &H2
CDRF_SKIPDEFAULT = &H4
CDRF_NOTIFYSUBITEMDRAW = &H20
End Enum
Public Type SIZE
cx As Long
cy As Long
End Type
Private Type SUBCLASSWINDOW
hWnd As Long
defProc As Long
FormObject As Object
LVControl As Object
iSubItem As Long
LVHighlightColor As Long
End Type
Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDest As Any, pSource As Any, ByVal dwLength 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 DrawText Lib "user32" Alias "DrawTextA" (ByVal hDC As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long
Private Declare Function FillRect Lib "user32" (ByVal hDC As Long, lpRect As RECT, ByVal hBrush As Long) As Long
Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
Private Declare Function GetTextExtentPoint32 Lib "gdi32" Alias "GetTextExtentPoint32A" (ByVal hDC As Long, ByVal lpsz As String, ByVal cbString As Long, lpSize As SIZE) As Long
Private Declare Function InvertRect Lib "user32" (ByVal hDC As Long, lpRect As RECT) 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 Function SendMessageRECT Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As RECT) As Long
Private Declare Function SetTextColor Lib "gdi32" (ByVal hDC As Long, ByVal crColor 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 scWindow() As SUBCLASSWINDOW
Public Sub CreateQ3ColorArray()
Q3ColorArray(0) = vbBlack
Q3ColorArray(1) = vbRed
Q3ColorArray(2) = vbGreen
Q3ColorArray(3) = vbYellow
Q3ColorArray(4) = vbBlue
Q3ColorArray(5) = vbCyan
Q3ColorArray(6) = vbMagenta
Q3ColorArray(7) = vbBlack
Q3ColorArray(8) = vbBlack
Q3ColorArray(9) = vbRed
End Sub
Private Sub DrawPlayerName(PlayerName As String, hDC As Long, rc As RECT, FixedPlayerNameLength As Long)
Dim i As Long
Dim TmpChr As String
Dim DrawnCount As Long
Dim TextSize As SIZE
Dim OldLeft As Long
OldLeft = rc.Left
DrawnCount = 0
SetTextColor hDC, Q3ColorArray(0)
For i = 1 To Len(PlayerName)
If Mid(PlayerName, i, 1) = "^" And i < Len(PlayerName) Then
TmpChr = Mid(PlayerName, i + 1, 1)
If Asc(TmpChr) >= 48 And Asc(TmpChr) <= 57 Then
SetTextColor hDC, Q3ColorArray(Asc(TmpChr) - 48)
i = i + 1
GoTo NextChar
ElseIf TmpChr = "^" Then
i = i + 1
Else
i = i + 1
GoTo NextChar
End If
End If
DrawText hDC, Mid(PlayerName, i, 1), 1, rc, DT_VCENTER
DrawnCount = DrawnCount + 1
GetTextExtentPoint32 hDC, Mid(PlayerName, i, 1), 1, TextSize
rc.Left = rc.Left + TextSize.cx
If FixedPlayerNameLength > 0 Then
If FixedPlayerNameLength - 3 = DrawnCount Then
SetTextColor hDC, Q3ColorArray(0)
DrawText hDC, "...", 3, rc, DT_VCENTER
i = Len(PlayerName)
End If
End If
NextChar:
Next i
rc.Left = OldLeft
End Sub
Private Sub GetCellRect(hWnd As Long, iRow As Long, iCol As Long, rc As RECT)
If iCol Then
GetSubItemRect hWnd, iRow, iCol, rc
Else
GetItemRect hWnd, iRow, rc
End If
End Sub
Private Function GetItemRect(hWnd As Long, iRow As Long, rc As RECT) As Long
rc.Left = 0
GetItemRect = SendMessageRECT(hWnd, LVM_GETITEMRECT, iRow, rc)
End Function
Private Function GetSubItemRect(hWnd As Long, iRow As Long, iCol As Long, rc As RECT) As Long
rc.Left = 0
rc.Top = iCol
GetSubItemRect = SendMessageRECT(hWnd, LVM_GETSUBITEMRECT, iRow, rc)
End Function
Public Sub LVGotFocus(hWnd As Long)
On Error Resume Next
Dim i As Integer
For i = 1 To UBound(scWindow)
If scWindow(i).hWnd = hWnd Then
scWindow(i).LVHighlightColor = GetSysColor(COLOR_HIGHLIGHT)
Exit For
End If
Next i
End Sub
Public Sub LVLostFocus(hWnd As Long)
On Error Resume Next
Dim i As Integer
For i = 1 To UBound(scWindow)
If scWindow(i).hWnd = hWnd Then
scWindow(i).LVHighlightColor = GetSysColor(COLOR_INACTIVEBORDER)
Exit For
End If
Next i
End Sub
Public Sub LVNoFocus(hWnd As Long)
On Error Resume Next
Dim i As Integer
For i = 1 To UBound(scWindow)
If scWindow(i).hWnd = hWnd Then
scWindow(i).LVHighlightColor = -1
Exit For
End If
Next i
End Sub
Public Sub SubClassListViewParentWnd(ByVal hWnd As Long, FormObj As Object, LVControl As Object, ByVal iSubItem As Long)
Dim scWnd As SUBCLASSWINDOW
scWnd.hWnd = hWnd
On Error Resume Next
ReDim Preserve scWindow(UBound(scWindow) + 1)
If Err Then ReDim scWindow(1)
scWnd.defProc = SubClass(scWnd.hWnd)
Set scWnd.FormObject = FormObj
Set scWnd.LVControl = LVControl
scWnd.iSubItem = iSubItem
scWindow(UBound(scWindow)) = scWnd
End Sub
Private Function SubClass(hWnd As Long) As Long
Dim defWindowProc As Long
On Error Resume Next
defWindowProc = SetWindowLong(hWnd, GWL_WNDPROC, AddressOf WindowProc)
SubClass = defWindowProc
End Function
Public Sub UnSubClassListViewParentWnd(ByVal hWnd As Long)
On Error Resume Next
Dim i As Integer, scWnd As SUBCLASSWINDOW, found As Integer
found = -1
For i = 1 To UBound(scWindow)
If scWindow(i).hWnd = hWnd Then
scWnd = scWindow(i)
found = i
End If
Next i
If found <> -1 Then
UnSubClass hWnd, scWnd.defProc
If found < UBound(scWindow) Then
For i = found To UBound(scWindow) - 1
scWindow(i) = scWindow(i + 1)
Next
End If
ReDim Preserve scWindow(UBound(scWindow) - 1)
End If
End Sub
Public Sub UnSubClassListViewParentWndAll()
On Error Resume Next
If UBound(scWindow) < 1 Then Exit Sub
If Err <> 0 Then Exit Sub
Dim i As Integer
For i = 1 To UBound(scWindow)
If scWindow(i).hWnd > 0 Then UnSubClass scWindow(i).hWnd, scWindow(i).defProc
Next i
ReDim scWindow(0)
End Sub
Private Sub UnSubClass(hWnd As Long, PrevDefProc As Long)
SetWindowLong hWnd, GWL_WNDPROC, PrevDefProc
End Sub
Private Function WindowProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Dim i As Integer, bWndFound As Boolean, scWnd As SUBCLASSWINDOW
Dim rc As RECT, rectBrush As Long, FixedPlayerName As String
On Error Resume Next
For i = 1 To UBound(scWindow)
If scWindow(i).hWnd = hWnd Then
bWndFound = True
scWnd = scWindow(i)
Exit For
End If
Next i
If bWndFound Then
Select Case uMsg
Case WM_NOTIFY
Static lvcd As NMLVCUSTOMDRAW
CopyMemory lvcd, ByVal lParam, Len(lvcd)
If lvcd.nmcd.hdr.hWndFrom = scWnd.LVControl.hWnd Then
Select Case lvcd.nmcd.hdr.code
Case NM_CUSTOMDRAW
Select Case lvcd.nmcd.dwDrawStage
Case CDDS_PREPAINT, CDDS_ITEMPREPAINT
WindowProc = CDRF_NOTIFYSUBITEMDRAW
Case CDDS_ITEMPREPAINT Or CDDS_SUBITEM
If lvcd.iSubItem = scWnd.iSubItem Then
GetCellRect scWnd.LVControl.hWnd, lvcd.nmcd.dwItemSpec, lvcd.iSubItem, rc
FixedPlayerName = scWnd.LVControl.ListItems(lvcd.nmcd.dwItemSpec + 1).SubItems(scWnd.iSubItem)
DrawText MainForm.hDC, FixedPlayerName, -1, rc, DT_MODIFYSTRING Or DT_WORD_ELLIPSIS
If Not (scWnd.LVControl.SelectedItem Is Nothing) And scWnd.LVHighlightColor <> -1 Then
If lvcd.nmcd.dwItemSpec = scWnd.LVControl.SelectedItem.Index - 1 And _
scWnd.LVControl.SelectedItem.Selected Then
rectBrush = CreateSolidBrush(scWnd.LVHighlightColor)
FillRect lvcd.nmcd.hDC, rc, rectBrush
DeleteObject rectBrush
If scWnd.LVHighlightColor = GetSysColor(COLOR_HIGHLIGHT) Then InvertRect lvcd.nmcd.hDC, rc
End If
End If
DrawPlayerName scWnd.LVControl.ListItems(lvcd.nmcd.dwItemSpec + 1).Tag, _
lvcd.nmcd.hDC, rc, IIf(FixedPlayerName = scWnd.LVControl.ListItems(lvcd.nmcd.dwItemSpec + 1).SubItems(scWnd.iSubItem), _
0, Len(FixedPlayerName))
If Not (scWnd.LVControl.SelectedItem Is Nothing) And scWnd.LVHighlightColor = GetSysColor(COLOR_HIGHLIGHT) Then
If lvcd.nmcd.dwItemSpec = scWnd.LVControl.SelectedItem.Index - 1 And _
scWnd.LVControl.SelectedItem.Selected Then
InvertRect lvcd.nmcd.hDC, rc
End If
End If
SetTextColor lvcd.nmcd.hDC, lvcd.clrText
CopyMemory ByVal lParam, lvcd, Len(lvcd)
WindowProc = CDRF_SKIPDEFAULT
Else
WindowProc = CDRF_DODEFAULT
End If
Case Else
WindowProc = CallWindowProc(scWnd.defProc, hWnd, uMsg, wParam, lParam)
End Select
Case Else
WindowProc = CallWindowProc(scWnd.defProc, hWnd, uMsg, wParam, lParam)
End Select
Else
WindowProc = CallWindowProc(scWnd.defProc, hWnd, uMsg, wParam, lParam)
End If
Case Else
WindowProc = CallWindowProc(scWnd.defProc, hWnd, uMsg, wParam, lParam)
End Select
End If
End Function
Download ListViewParentSubClassMod.bas