Find all our projects in development below.
All source code is GNU General Public License (GPL)
Browsing QuickQuery HL Edition/ListViewParentSubClassMod.bas (10.70 KB)
Attribute VB_Name = "ListViewParentSubClassMod"
Private Const LVTYPEPROP = "lvType"
Private Const GWL_WNDPROC = (-4)
Private Const WM_GETFONT = &H31
Private Const WM_NOTIFY = &H4E
Private Const NM_FIRST = -0&
Private Const NM_CUSTOMDRAW = (NM_FIRST - 12)
Private Const LVIF_TEXT = &H1
Private Const LVM_FIRST = &H1000
Private Const LVM_GETITEMTEXT = (LVM_FIRST + 45)
Private Const LVM_SETITEMTEXT = (LVM_FIRST + 46)
Private Const DARKGREEN = &H8000&
Private Const DARKRED = &H80&
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
Private Type SUBCLASSWINDOW
hWnd As Long
defProc As Long
End Type
Private Type LV_ITEM
mask As Long
iItem As Long
iSubItem As Long
state As Long
stateMask As Long
pszText As String
cchTextMax As Long
iImage As Long
lParam As Long
iIndent 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 GetProp Lib "user32" Alias "GetPropA" (ByVal hWnd As Long, ByVal lpString As String) As Long
Private Declare Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hWnd As Long, ByVal lpString As String) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject 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 Function SetProp Lib "user32" Alias "SetPropA" (ByVal hWnd As Long, ByVal lpString As String, ByVal hData 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
Private Function GetSubItemText(hWnd As Long, hIndex As Long, iSubItem As Long) As String
Dim objItem As LV_ITEM
objItem.mask = LVIF_TEXT
objItem.iSubItem = iSubItem
objItem.pszText = String(128, vbNullChar)
objItem.cchTextMax = Len(objItem.pszText)
SendMessage hWnd, LVM_GETITEMTEXT, hIndex, objItem
GetSubItemText = objItem.pszText
If InStr(GetSubItemText, vbNullChar) Then GetSubItemText = Left(GetSubItemText, InStr(GetSubItemText, vbNullChar) - 1)
End Function
Public Sub SetLVType(hWnd As Long, ByVal lvType As Long)
SetProp hWnd, LVTYPEPROP, lvType
End Sub
Public Sub RemoveLVType(hWnd As Long)
RemoveProp hWnd, LVTYPEPROP
End Sub
Public Function SetSubItemText(hWnd As Long, hIndex As Long, iSubItem As Long, strValue As String) As Long
Dim objItem As LV_ITEM
objItem.mask = LVIF_TEXT
objItem.iSubItem = iSubItem
objItem.pszText = strValue
objItem.cchTextMax = Len(strValue)
SetSubItemText = SendMessage(hWnd, LVM_SETITEMTEXT, hIndex, objItem)
End Function
Public Sub SubClassListViewParentWnd(ByVal hWnd As Long, Optional bNoSubClass As Boolean)
Dim scWnd As SUBCLASSWINDOW
scWnd.hWnd = hWnd
On Error Resume Next
ReDim Preserve scWindow(UBound(scWindow) + 1)
If Err Then ReDim scWindow(1)
If bNoSubClass = False Then scWnd.defProc = SubClass(scWnd.hWnd)
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 LVPSCWindowProc)
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
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
Public Function LVPSCWindowProc(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 lvType As Long
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)
lvType = GetProp(lvcd.nmcd.hdr.hWndFrom, LVTYPEPROP)
If lvType > 0 Then
Select Case lvcd.nmcd.hdr.code
Case NM_CUSTOMDRAW
Select Case lvcd.nmcd.dwDrawStage
Case CDDS_PREPAINT
LVPSCWindowProc = CDRF_NOTIFYITEMDRAW
Case CDDS_ITEMPREPAINT
Dim strText As String
Dim strSubItem As String
Dim strSubItem2 As String
If lvType = 1 Then
strText = LCase(GetSubItemText(lvcd.nmcd.hdr.hWndFrom, lvcd.nmcd.dwItemSpec, 0))
CopyMemory lvcd, ByVal lParam, Len(lvcd)
strSubItem = GetSubItemText(lvcd.nmcd.hdr.hWndFrom, lvcd.nmcd.dwItemSpec, 1)
CopyMemory lvcd, ByVal lParam, Len(lvcd)
If strText = "sv_password" And Val(strSubItem) > 0 Then lvcd.clrText = vbRed
If strText = "mp_friendlyfire" And Val(strSubItem) > 0 Then lvcd.clrText = vbRed
If strText = "reserve_slots" And Val(strSubItem) > 0 Then lvcd.clrText = vbRed
If strText = "sv_contact" And InStr(strSubItem, "{PB REQ}") Then lvcd.clrText = vbRed
If strText = "sv_contact" And InStr(strSubItem, "{PALADIN REQ}") Then lvcd.clrText = vbRed
If strText = "cdrequired" And Val(strSubItem) > 0 Then lvcd.clrText = vbRed
ElseIf lvType = 2 And MainForm.FilterMenu.Enabled Then
strSubItem = GetSubItemText(lvcd.nmcd.hdr.hWndFrom, lvcd.nmcd.dwItemSpec, 7)
CopyMemory lvcd, ByVal lParam, Len(lvcd)
strSubItem2 = GetSubItemText(lvcd.nmcd.hdr.hWndFrom, lvcd.nmcd.dwItemSpec, 6)
CopyMemory lvcd, ByVal lParam, Len(lvcd)
If ((lvcd.nmcd.uItemState And CDIS_HOT) = CDIS_HOT) = False And strSubItem = "p" And MainForm.HighlightProxyMenu.Checked Then lvcd.clrText = DARKGREEN
If ((lvcd.nmcd.uItemState And CDIS_HOT) = CDIS_HOT) = False And strSubItem2 = "1" And MainForm.HighlightLockedMenu.Checked Then lvcd.clrText = DARKRED
ElseIf lvType = 3 Then
If lvcd.nmcd.dwItemSpec = 6 Then
SelectObject lvcd.nmcd.hDC, SendMessage(hWnd, WM_GETFONT, 0, 0)
LVPSCWindowProc = CDRF_NOTIFYSUBITEMDRAW Or CDRF_NEWFONT
CopyMemory ByVal lParam, lvcd, Len(lvcd)
Exit Function
End If
End If
LVPSCWindowProc = CDRF_NOTIFYSUBITEMDRAW
CopyMemory ByVal lParam, lvcd, Len(lvcd)
Case Else
LVPSCWindowProc = CallWindowProc(scWnd.defProc, hWnd, uMsg, wParam, lParam)
End Select
Case Else
LVPSCWindowProc = CallWindowProc(scWnd.defProc, hWnd, uMsg, wParam, lParam)
End Select
Else
LVPSCWindowProc = CallWindowProc(scWnd.defProc, hWnd, uMsg, wParam, lParam)
End If
Case Else
LVPSCWindowProc = CallWindowProc(scWnd.defProc, hWnd, uMsg, wParam, lParam)
End Select
End If
End Function
Download QuickQuery HL Edition/ListViewParentSubClassMod.bas