纯代码实现窗体Listview控件网格线颜色、行高和选中行颜色的设置

ivccav

之前写过3篇关于Listview控件的帖子（如下），阅读人数还挺多，其中一帖阅读量10W+，该控件受欢迎程度可见一斑。
随着64位Office开始支持Listview控件，我想需要了解该控件使用的需求只会更大。

VBA窗体Listview控件完全教程
https://club.excelhome.net/thread-1424969-1-1.html

用NM_CUSTOMDRAW自定义绘制技术实现Listview控件隔行换色
https://club.excelhome.net/thread-1428537-1-1.html

窗体Listview控件实现可编辑功能的完美解决方法
https://club.excelhome.net/thread-1423746-1-1.html


虽然曾经写过“完全教程”，但有一个问题始终没有解决，即Listview控件的网格线颜色无法设定。
我在微软官网查阅了很多NM_CUSTOMDRAW内容，找不到设置网格线颜色的内容。NM_CUSTOMDRAW用于设置每行交替色是很方便的，代码简单。

众所周知，控件绘制可有三种方式：

1.处理 WM_PAINT消息
这是最极端的方式，执行一个 WM_PAINT 处理程序，并且自己完成所有的绘制工作。这意味着代码将需要进行一些与呈现控件相关的琐事 — 创建适当的设备上下文（一个或多个），决定控件的大小和位置，绘制控件等。在绘制过程中，很少需要这种级别的控件。

2.所有者绘制(OwnerDraw)
控制控件绘制的第2种方法是所有者绘制，它是用于开发自定义控件最普通的技术。该技术普遍使用的主要原因在于，系统可为提供很多帮助。在呈现控件的之前，Windows已经创建并填写了设备上下文，决定了控件的大小和位置，并且向您传递信息以使您了解此刻绘制的需求。对于列表控件（例如Listbox和Listview等），Windows将为列表中的每一项调用绘制代码，这意味着您只需绘制这些项，而无需考虑控件的其他方面。这里的”Owner”可以理解为控件类的派生类。

如何启用控件的OwnerDraw属性呢？对于ListView控件，可以设置LVS_OWNERDRAWFIXED风格。
使用OwnerDraw方式，我们需要处理WM_MEASUREITEM和WM_DRAWITEM消息。
如果要设置每行行高，只能使用OwnerDraw方式绘制，且只有在收到WM_MEASUREITEM消息时能进行设置。
设置行高在MEASUREITEMSTRUCT结构体的ItemHeight成员中设置。

Private Type MEASUREITEMSTRUCT
    CtlType                         As Long
    CtlID                           As Long
    itemID                          As Long
    itemWidth                       As Long
    ItemHeight                      As Long
    itemData                        As Long
End Type
所有者绘制(OwnerDraw)方式主要处理WM_DRAWITEM消息对Item和Subitem进行边框绘制。

3.自定义绘制(CustomDraw)
CustomDraw不需要设置风格。只需在接收到NM_CUSTOMDRAW通知时(借由WM_NOTIFY消息）给父窗口。控件的父窗口可以选择处理或不处理此通知。在CustomDraw场景下，控件的大部分绘制工作还是由系统默认完成，我们只是在系统绘制之前或者之后对控件的呈现进行某种方式的”微调”。比如，我们可以使用CustomDraw机制来修改ListView控件中的项目背景色，文字的前景或背景色等。在控件绘制的整个阶段中，系统划分了一系列不同的阶段，开发者设置了感兴趣的阶段后，系统就会在每个开发者感兴趣的阶段发送NM_CUSTOMDRAW通知。当我们收到NM_CUSTOMDRAW通知的时候，我们可以根据通知中的DrawStage知道当前绘制的阶段。具体可看微软官方文档。

本帖使用的是第二种方式。代码来源于网络，是VB6环境下写的一个类模块。如果直接放在VBA中运行，会导致应用软件直接崩溃。我修改了少量参数，让其可以在VBA中正常运行，并针对在VBA中无法触发WM_MEASUREITEM消息导致无法设置行高的问题，写了触发该消息的子过程。还写了应用示例。

该类的接口如下：



应用实际效果图：






附件下载见10楼：

64位API声明参考：
https://club.excelhome.net/thread-1656964-1-1.html

ivccav

完整源代码和应用案例：







纯代码实现窗体Listview控件网格线颜色、行高和选中行颜色的设置.zip (117.06 KB, 下载次数: 512)

2023-3-25 00:26 上传

点击文件名下载附件

ivccav

新建一个类模块，取名为：CCustomListView


结构体、枚举和常量声明：

1. Private Type TRACKMOUSEEVENTTYPE
   
2.     cbSize                          As Long
   
3.     dwFlags                         As Long
   
4.     hwndTrack                       As Long
   
5.     dwHoverTime                     As Long
   
6. End Type
   
7. 
   
8. Private Type tSubData
   
9.     hwnd                            As Long
   
10.     nAddrSub                        As Long
    
11.     nAddrOrig                       As Long
    
12.     nMsgCntA                        As Long
    
13.     nMsgCntB                        As Long
    
14.     aMsgTblA()                      As Long
    
15.     aMsgTblB()                      As Long
    
16. End Type
    
17. 
    
18. Private Enum eMsgWhen
    
19.     [MSG_AFTER] = &H1
    
20.     [MSG_BEFORE] = &H2
    
21.     [MSG_BEFORE_AND_AFTER] = MSG_AFTER Or MSG_BEFORE
    
22. End Enum
    
23. 
    
24. Private Const ALL_MESSAGES          As Long = &HFFFF
    
25. Private Const CODE_LEN              As Long = &HC5
    
26. Private Const GWL_WNDPROC           As Long = &HFFFC
    
27. Private Const PATCH_04              As Long = &H58
    
28. Private Const PATCH_05              As Long = &H5D
    
29. Private Const PATCH_08              As Long = &H84
    
30. Private Const PATCH_09              As Long = &H89
    
31. 
    
32. Private Type RECT
    
33.     Left                            As Long
    
34.     Top                             As Long
    
35.     Right                           As Long
    
36.     Bottom                          As Long
    
37. End Type
    
38. 
    
39. Private Type MEASUREITEMSTRUCT
    
40.     CtlType                         As Long
    
41.     CtlID                           As Long
    
42.     itemID                          As Long
    
43.     itemWidth                       As Long
    
44.     ItemHeight                      As Long
    
45.     itemData                        As Long
    
46. End Type
    
47. 
    
48. Private Type DRAWITEMSTRUCT
    
49.     CtlType                         As Long
    
50.     CtlID                           As Long
    
51.     itemID                          As Long
    
52.     itemAction                      As Long
    
53.     itemState                       As Long
    
54.     hwndItem                        As Long
    
55.     hdc                             As Long
    
56.     rcItem                          As RECT
    
57.     itemData                        As Long
    
58. End Type
    
59. 
    
60. Private Type NMHDR
    
61.     hWndFrom                        As Long
    
62.     idFrom                          As Long
    
63.     Code                            As Long
    
64. End Type
    
65. 
    
66. Private Type NMCUSTOMDRAW
    
67.     hdr                             As NMHDR
    
68.     dwDrawStage                     As Long
    
69.     hdc                             As Long
    
70.     rc                              As RECT
    
71.     dwItemSpec                      As Long
    
72.     uItemState                      As Long
    
73.     lItemlParam                     As Long
    
74. End Type
    
75. 
    
76. Private Type NMLVCUSTOMDRAW
    
77.     nmcd                                As NMCUSTOMDRAW
    
78.     clrText                             As Long
    
79.     clrTextBk                           As Long
    
80.     iSubItem                            As Long
    
81. End Type
    
82. 
    
83. Private Type LVITEM
    
84.     mask                                As Long
    
85.     iItem                               As Long
    
86.     iSubItem                            As Long
    
87.     state                               As Long
    
88.     stateMask                           As Long
    
89.     pszText                             As Long
    
90.     cchTextMax                          As Long
    
91.     iImage                              As Long
    
92.     lParam                              As Long
    
93.     iIndent                             As Long
    
94. End Type
    
95. 
    
96. 
    
97. Private Type HDITEM
    
98.     mask                                As Long
    
99.     cxy                                 As Long
    
100.     pszText                             As Long
     
101.     hbm                                 As Long
     
102.     cchTextMax                          As Long
     
103.     fmt                                 As Long
     
104.     lParam                              As Long
     
105.     iImage                              As Long
     
106.     iOrder                              As Long
     
107.     type                                As Long
     
108.     pvFilter                            As Long
     
109.     state                               As Long
     
110. End Type
     
111. 
     
112. Private Const WM_NCDESTROY              As Long = &H82
     
113. Private Const WM_MEASUREITEM            As Long = &H2C
     
114. Private Const WM_DRAWITEM               As Long = &H2B
     
115. 
     
116. Private Const LVM_FIRST                 As Long = &H1000
     
117. Private Const LVM_GETHEADER             As Long = (LVM_FIRST + 31)
     
118. Private Const LVM_GETITEMTEXTA          As Long = (LVM_FIRST + 45)
     
119. 
     
120. Private Const LVS_OWNERDRAWFIXED        As Long = &H400
     
121. 
     
122. Private Const LVIF_TEXT                 As Long = &H1
     
123. 
     
124. Private Const DT_LEFT                   As Long = &H0
     
125. Private Const DT_TOP                    As Long = &H0
     
126. Private Const DT_CENTER                 As Long = &H1
     
127. Private Const DT_RIGHT                  As Long = &H2
     
128. Private Const DT_VCENTER                As Long = &H4
     
129. Private Const DT_BOTTOM                 As Long = &H8
     
130. Private Const DT_SINGLELINE             As Long = &H20
     
131. Private Const DT_END_ELLIPSIS           As Long = &H8000&
     
132. 
     
133. Private Const DCB_ACCUMULATE        As Long = &H2
     
134. Private Const DCB_DISABLE           As Long = &H8
     
135. Private Const DCB_ENABLE            As Long = &H4
     
136. Private Const DCB_RESET             As Long = &H1
     
137. Private Const DCB_SET               As Long = (DCB_RESET Or DCB_ACCUMULATE)
     
138. 
     
139. Private Const HDM_FIRST                 As Long = &H1200
     
140. Private Const HDM_GETITEMCOUNT          As Long = (HDM_FIRST + 0)
     
141. Private Const HDM_GETITEMA              As Long = (HDM_FIRST + 3)
     
142. Private Const HDM_GETITEMRECT           As Long = (HDM_FIRST + 7)
     
143. 
     
144. Private Const HDI_FORMAT                As Long = &H4
     
145. 
     
146. Private Const HDF_LEFT                  As Long = 0
     
147. Private Const HDF_RIGHT                 As Long = 1
     
148. Private Const HDF_CENTER                As Long = 2
     
149. 
     
150. Private Const GWL_STYLE                 As Long = (-16)
     
151. 
     
152. Private Const PS_SOLID                  As Long = 0
     
153. 
     
154. Private Const ODT_LISTVIEW              As Long = 102
     
155. Private Const ODS_SELECTED              As Long = &H1

复制代码

ivccav

API和模块变量声明

1. Private Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long
   
2. Private Declare Function GetModuleHandleA Lib "kernel32" (ByVal lpModuleName As String) As Long
   
3. Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long
   
4. Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
   
5. Private Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long
   
6. Private Declare Function LoadLibraryA Lib "kernel32" (ByVal lpLibFileName As String) As Long
   
7. Private Declare Sub RtlMoveMemory Lib "kernel32" (Destination As Any, Source As Any, ByVal Length As Long)
   
8. Private Declare Function SetWindowLongA Lib "user32" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
   
9. Private Declare Function LoadLibrary Lib "kernel32.dll" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long
   
10. Private Declare Function VirtualProtect Lib "kernel32" (lpAddress As Any, ByVal dwSize As Long, ByVal flNewProtect As Long, lpflOldProtect As Long) As Long
    
11. 
    
12. Private Declare Function TrackMouseEvent2 Lib "comctl32.dll" Alias "_TrackMouseEvent" (ByRef lpEventTrack As TRACKMOUSEEVENTTYPE) As Long ' Win95 w/ IE 3.0
    
13. Private Declare Function TrackMouseEvent Lib "user32.dll" (ByRef lpEventTrack As TRACKMOUSEEVENTTYPE) As Long ' Win98 or later
    
14. 
    
15. Private Declare Function LocalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal wBytes As Long) As Long
    
16. Private Declare Function LocalFree Lib "kernel32" (ByVal hMem As Long) As Long
    
17. 
    
18. Private Declare Function SetBoundsRect Lib "gdi32" (ByVal hdc As Long, lprcBounds As RECT, ByVal flags As Long) As Long
    
19. Private Declare Function GetBoundsRect Lib "gdi32" (ByVal hdc As Long, lprcBounds As RECT, ByVal flags As Long) As Long
    
20. Private Declare Function IntersectRect Lib "user32" (lpDestRect As RECT, lpSrc1Rect As RECT, lpSrc2Rect As RECT) As Long
    
21. Private Declare Function IsRectEmpty Lib "user32" (lpRect As RECT) As Long
    
22. Private Declare Function SetRect Lib "user32" (lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
    
23. Private Declare Function InflateRect Lib "user32" (lpRect As RECT, ByVal x As Long, ByVal y As Long) As Long
    
24. Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
    
25. Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
    
26. Private Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
    
27. 
    
28. Private Declare Function GetParent Lib "user32" (ByVal hwnd As Long) As Long
    
29. Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
    
30. Private Declare Function FillRect Lib "user32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long
    
31. Private Declare Function InvalidateRect Lib "user32" (ByVal hwnd As Long, lpRect As Any, ByVal bErase As Long) As Long
    
32. 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
    
33. Private Declare Function GetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
    
34. Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
    
35. Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
    
36. 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
    
37. Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
    
38. Private Declare Function Rectangle Lib "gdi32" (ByVal hdc As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
    
39. Private Declare Function CreatePen Lib "gdi32" (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long
    
40. Private Declare Function GetDlgItem Lib "user32" (ByVal hDlg As Long, ByVal nIDDlgItem As Long) As Long
    
41. 
    
42. Private sc_aSubData()           As tSubData
    
43. Private sc_aBuf(1 To CODE_LEN)  As Byte
    
44. Private sc_pCWP                 As Long
    
45. Private sc_pEbMode              As Long
    
46. Private sc_pSWL                 As Long
    
47. 
    
48. '''''''''''''''''''''''''''''''''''''''''''''''''''''
    
49. Private m_bIsTrackHandler32     As Boolean
    
50. Private m_bIsTracked            As Boolean
    
51. 
    
52. Private m_hWnd                  As Long
    
53. Private m_hHeaderWnd            As Long
    
54. Private m_hParentWnd            As Long
    
55. Private m_dwOriginStyle         As Long
    
56. 
    
57. Private m_clrItemBkColor1       As Long
    
58. Private m_clrItemBkColor2       As Long
    
59. Private m_clrGridColor          As Long
    
60. Private m_clrSelectedItemBkColor       As Long
    
61. 
    
62. Private m_hItemBkBrush1         As Long
    
63. Private m_hItemBkBrush2         As Long
    
64. Private m_hGridPen              As Long
    
65. Private m_hSelectedItemBkBrush  As Long
    
66. 
    
67. Private m_bItemBkColorHorizontal    As Boolean
    
68. Private m_bShowGrid             As Boolean
    
69. Private m_nItemHeight           As Long

复制代码

ivccav

入口函数和消息处理：

1. Public Sub zSubclass_Proc(ByVal bBefore As Boolean, ByRef bHandled As Boolean, ByRef lReturn As Long, ByRef lhWnd As Long, ByRef uMsg As Long, ByRef wParam As Long, ByRef lParam As Long)
   
2.     Select Case uMsg
   
3.         Case WM_NCDESTROY
   
4.             Detach
   
5.             Exit Sub
   
6.             
   
7.         Case WM_MEASUREITEM
   
8.             lReturn = OnMeasureItem(lhWnd, uMsg, wParam, lParam, bHandled)
   
9.             Exit Sub
   
10.             
    
11.         Case WM_DRAWITEM
    
12.             lReturn = OnDrawItem(lhWnd, uMsg, wParam, lParam, bHandled)
    
13.             Exit Sub
    
14.             
    
15.     End Select
    
16. End Sub
    
17. 
    
18. Private Sub Subclass_AddMsg(ByVal lng_hWnd As Long, ByVal uMsg As Long, Optional ByVal When As eMsgWhen = MSG_AFTER)
    
19.     With sc_aSubData(zIdx(lng_hWnd))
    
20.         If (When And eMsgWhen.MSG_BEFORE) Then
    
21.             Call zAddMsg(uMsg, .aMsgTblB, .nMsgCntB, eMsgWhen.MSG_BEFORE, .nAddrSub)
    
22.         End If
    
23.         If (When And eMsgWhen.MSG_AFTER) Then
    
24.             Call zAddMsg(uMsg, .aMsgTblA, .nMsgCntA, eMsgWhen.MSG_AFTER, .nAddrSub)
    
25.         End If
    
26.     End With
    
27. End Sub
    
28. 
    
29. Private Sub Subclass_DelMsg(ByVal lng_hWnd As Long, ByVal uMsg As Long, Optional ByVal When As eMsgWhen = MSG_AFTER)
    
30.   
    
31.     With sc_aSubData(zIdx(lng_hWnd))
    
32.         If (When And eMsgWhen.MSG_BEFORE) Then
    
33.             Call zDelMsg(uMsg, .aMsgTblB, .nMsgCntB, eMsgWhen.MSG_BEFORE, .nAddrSub)
    
34.         End If
    
35.         If (When And eMsgWhen.MSG_AFTER) Then
    
36.             Call zDelMsg(uMsg, .aMsgTblA, .nMsgCntA, eMsgWhen.MSG_AFTER, .nAddrSub)
    
37.         End If
    
38.     End With
    
39. End Sub

复制代码

ivccav

汇编处理。功能是把入口函数完全封装在类中。避免使用标准模块的小尾巴。

1. Private Function Subclass_InIDE() As Boolean
   
2.     Subclass_InIDE = False
   
3. End Function
   
4. 
   
5. Private Function Subclass_Start(ByVal lng_hWnd As Long) As Long
   
6. 
   
7.   Dim i                        As Long
   
8.   Dim j                        As Long
   
9.   Dim nSubIdx                  As Long
   
10.   Dim sSubCode                 As String
    
11.   
    
12.   Const GMEM_FIXED             As Long = 0
    
13.   Const PAGE_EXECUTE_READWRITE As Long = &H40&
    
14.   Const PATCH_01               As Long = 18
    
15.   Const PATCH_02               As Long = 68
    
16.   Const PATCH_03               As Long = 78
    
17.   Const PATCH_06               As Long = 116
    
18.   Const PATCH_07               As Long = 121
    
19.   Const PATCH_0A               As Long = 186
    
20.   Const FUNC_CWP               As String = "CallWindowProcA"
    
21.   Const FUNC_EBM               As String = "EbMode"
    
22.   Const FUNC_SWL               As String = "SetWindowLongA"
    
23.   Const MOD_USER               As String = "user32"
    
24.   Const MOD_VBA5               As String = "vba5"
    
25.   Const MOD_VBA6               As String = "vba6"
    
26. 
    
27.     If (sc_aBuf(1) = 0) Then
    
28. 
    
29.         sSubCode = "5589E583C4F85731C08945FC8945F8EB0EE80000000083F802742185C07424E830000000837DF800750AE838000000E84D0000005F8B45FCC9C21000E826000000EBF168000000006AFCFF7508E800000000EBE031D24ABF00000000B900000000E82D000000C3FF7514FF7510FF750CFF75086800000000E8000000008945FCC331D2BF00000000B900000000E801000000C3E32F09C978078B450CF2AF75248D4514508D4510508D450C508D4508508D45FC508D45F85052B800000000508B00FF501CC3"
    
30.         i = 1
    
31.         Do While j < CODE_LEN
    
32.             j = j + 1
    
33.             sc_aBuf(j) = CByte("&H" & Mid$(sSubCode, i, 2))
    
34.             i = i + 2
    
35.         Loop
    
36.    
    
37.         If (Subclass_InIDE) Then
    
38.             sc_aBuf(16) = &H90
    
39.             sc_aBuf(17) = &H90
    
40.             sc_pEbMode = zAddrFunc(MOD_VBA6, FUNC_EBM)
    
41.             If (sc_pEbMode = 0) Then
    
42.                 sc_pEbMode = zAddrFunc(MOD_VBA5, FUNC_EBM)
    
43.             End If
    
44.         End If
    
45.    
    
46.         Call zPatchVal(VarPtr(sc_aBuf(1)), PATCH_0A, ObjPtr(Me))
    
47.    
    
48.         sc_pCWP = zAddrFunc(MOD_USER, FUNC_CWP)
    
49.         sc_pSWL = zAddrFunc(MOD_USER, FUNC_SWL)
    
50.         ReDim sc_aSubData(0 To 0) As tSubData
    
51.    
    
52.       Else
    
53.         nSubIdx = zIdx(lng_hWnd, True)
    
54.         If (nSubIdx = -1) Then
    
55.             nSubIdx = UBound(sc_aSubData()) + 1
    
56.             ReDim Preserve sc_aSubData(0 To nSubIdx) As tSubData
    
57.         End If
    
58.    
    
59.         Subclass_Start = nSubIdx
    
60.     End If
    
61. 
    
62.     With sc_aSubData(nSubIdx)
    
63.         
    
64.         .nAddrSub = GlobalAlloc(GMEM_FIXED, CODE_LEN)
    
65.         Call VirtualProtect(ByVal .nAddrSub, CODE_LEN, PAGE_EXECUTE_READWRITE, i)
    
66.         Call RtlMoveMemory(ByVal .nAddrSub, sc_aBuf(1), CODE_LEN)
    
67.    
    
68.         .hwnd = lng_hWnd
    
69.         .nAddrOrig = SetWindowLongA(.hwnd, GWL_WNDPROC, .nAddrSub)
    
70.    
    
71.         Call zPatchRel(.nAddrSub, PATCH_01, sc_pEbMode)
    
72.         Call zPatchVal(.nAddrSub, PATCH_02, .nAddrOrig)
    
73.         Call zPatchRel(.nAddrSub, PATCH_03, sc_pSWL)
    
74.         Call zPatchVal(.nAddrSub, PATCH_06, .nAddrOrig)
    
75.         Call zPatchRel(.nAddrSub, PATCH_07, sc_pCWP)
    
76.     End With
    
77. End Function
    
78. 
    
79. Private Sub Subclass_StopAll()
    
80.   
    
81.   Dim i As Long
    
82.   
    
83.     i = UBound(sc_aSubData())
    
84.     Do While i >= 0
    
85.         With sc_aSubData(i)
    
86.             If (.hwnd <> 0) Then
    
87.                 Call Subclass_Stop(.hwnd)
    
88.             End If
    
89.         End With
    
90.    
    
91.         i = i - 1
    
92.     Loop
    
93. End Sub
    
94. 
    
95. Private Sub Subclass_Stop(ByVal lng_hWnd As Long)
    
96.   
    
97.     With sc_aSubData(zIdx(lng_hWnd))
    
98.         Call SetWindowLongA(.hwnd, GWL_WNDPROC, .nAddrOrig)
    
99.         Call zPatchVal(.nAddrSub, PATCH_05, 0)
    
100.         Call zPatchVal(.nAddrSub, PATCH_09, 0)
     
101.         Call GlobalFree(.nAddrSub)
     
102.         .hwnd = 0
     
103.         .nMsgCntB = 0
     
104.         .nMsgCntA = 0
     
105.         Erase .aMsgTblB
     
106.         Erase .aMsgTblA
     
107.     End With
     
108. End Sub
     
109. 
     
110. 
     
111. Private Sub zAddMsg(ByVal uMsg As Long, ByRef aMsgTbl() As Long, ByRef nMsgCnt As Long, ByVal When As eMsgWhen, ByVal nAddr As Long)
     
112.   
     
113.   Dim nEntry  As Long
     
114.   Dim nOff1   As Long
     
115.   Dim nOff2   As Long
     
116.   
     
117.     If (uMsg = ALL_MESSAGES) Then
     
118.         nMsgCnt = ALL_MESSAGES
     
119.       Else
     
120.         Do While nEntry < nMsgCnt
     
121.             nEntry = nEntry + 1
     
122.         
     
123.             If (aMsgTbl(nEntry) = 0) Then
     
124.                 aMsgTbl(nEntry) = uMsg
     
125.                 Exit Sub
     
126.             ElseIf (aMsgTbl(nEntry) = uMsg) Then
     
127.                 Exit Sub
     
128.             End If
     
129.         Loop
     
130. 
     
131.         nMsgCnt = nMsgCnt + 1
     
132.         ReDim Preserve aMsgTbl(1 To nMsgCnt) As Long
     
133.         aMsgTbl(nMsgCnt) = uMsg
     
134.     End If
     
135. 
     
136.     If (When = eMsgWhen.MSG_BEFORE) Then
     
137.         nOff1 = PATCH_04
     
138.         nOff2 = PATCH_05
     
139.       Else
     
140.         nOff1 = PATCH_08
     
141.         nOff2 = PATCH_09
     
142.     End If
     
143. 
     
144.     If (uMsg <> ALL_MESSAGES) Then
     
145.         Call zPatchVal(nAddr, nOff1, VarPtr(aMsgTbl(1)))
     
146.     End If
     
147.     Call zPatchVal(nAddr, nOff2, nMsgCnt)
     
148. End Sub
     
149. 
     
150. Private Function zAddrFunc(ByVal sDLL As String, ByVal sProc As String) As Long
     
151.     zAddrFunc = GetProcAddress(GetModuleHandleA(sDLL), sProc)
     
152.     Debug.Assert zAddrFunc
     
153. End Function
     
154. 
     
155. Private Sub zDelMsg(ByVal uMsg As Long, ByRef aMsgTbl() As Long, ByRef nMsgCnt As Long, ByVal When As eMsgWhen, ByVal nAddr As Long)
     
156.   
     
157.   Dim nEntry As Long
     
158.   
     
159.     If (uMsg = ALL_MESSAGES) Then
     
160.         nMsgCnt = 0
     
161.         If When = eMsgWhen.MSG_BEFORE Then
     
162.             nEntry = PATCH_05
     
163.           Else
     
164.             nEntry = PATCH_09
     
165.         End If
     
166.         Call zPatchVal(nAddr, nEntry, 0)
     
167.       Else
     
168.         Do While nEntry < nMsgCnt
     
169.             nEntry = nEntry + 1
     
170.             If (aMsgTbl(nEntry) = uMsg) Then
     
171.                 aMsgTbl(nEntry) = 0
     
172.                 Exit Do
     
173.             End If
     
174.         Loop
     
175.     End If
     
176. End Sub
     
177. 
     
178. Private Function zIdx(ByVal lng_hWnd As Long, Optional ByVal bAdd As Boolean = False) As Long
     
179.   
     
180.     zIdx = UBound(sc_aSubData)
     
181.     Do While zIdx >= 0
     
182.         With sc_aSubData(zIdx)
     
183.             If (.hwnd = lng_hWnd) Then
     
184.                 If (Not bAdd) Then
     
185.                     Exit Function
     
186.                 End If
     
187.             ElseIf (.hwnd = 0) Then
     
188.                 If (bAdd) Then
     
189.                     Exit Function
     
190.                 End If
     
191.             End If
     
192.         End With
     
193.         zIdx = zIdx - 1
     
194.     Loop
     
195.   
     
196.     If (Not bAdd) Then
     
197.         Debug.Assert False
     
198.     End If
     
199. 
     
200. End Function
     
201. 
     
202. Private Sub zPatchRel(ByVal nAddr As Long, ByVal nOffset As Long, ByVal nTargetAddr As Long)
     
203.     Call RtlMoveMemory(ByVal nAddr + nOffset, nTargetAddr - nAddr - nOffset - 4, 4)
     
204. End Sub
     
205. 
     
206. Private Sub zPatchVal(ByVal nAddr As Long, ByVal nOffset As Long, ByVal nValue As Long)
     
207.     Call RtlMoveMemory(ByVal nAddr + nOffset, nValue, 4)
     
208. End Sub
     
209. 
     
210. Private Function zSetTrue(ByRef bValue As Boolean) As Boolean
     
211.     zSetTrue = True
     
212.     bValue = True
     
213. End Function

复制代码

ivccav

类的初始化和销毁:

1. Private Sub Class_Initialize()
   
2.     m_bIsTrackHandler32 = IsFunctionSupported("TrackMouseEvent", "User32")
   
3.    
   
4.     m_hWnd = 0
   
5.     m_dwOriginStyle = 0
   
6.    
   
7.     m_hItemBkBrush1 = m_hItemBkBrush2 = 0
   
8.     m_hGridPen = 0
   
9.     m_bItemBkColorHorizontal = False
   
10.     ItemHeight = 20
    
11.     ShowGird = True
    
12.    
    
13.     ItemBkColor1 = &HFFFFFF
    
14.     ItemBkColor2 = &HFDF8F0
    
15.     GridColor = &HE5D7D0
    
16.     SelectedItemBkColor = &HABECFC
    
17. End Sub
    
18. 
    
19. Private Sub Class_Terminate()
    
20.     Call Detach
    
21.    
    
22.     If (m_hItemBkBrush1 <> 0) Then
    
23.         Call DeleteObject(m_hItemBkBrush1)
    
24.         m_hItemBkBrush1 = 0
    
25.     End If
    
26.    
    
27.     If (m_hItemBkBrush2 <> 0) Then
    
28.         Call DeleteObject(m_hItemBkBrush2)
    
29.         m_hItemBkBrush2 = 0
    
30.     End If
    
31.    
    
32.     If (m_hSelectedItemBkBrush <> 0) Then
    
33.         Call DeleteObject(m_hSelectedItemBkBrush)
    
34.         m_hSelectedItemBkBrush = 0
    
35.     End If
    
36.    
    
37.     If (m_hGridPen <> 0) Then
    
38.         Call DeleteObject(m_hGridPen)
    
39.         m_hGridPen = 0
    
40.     End If
    
41. End Sub
    
42. 
    
43. Private Function IsFunctionSupported(sFunction As String, sModule As String) As Boolean
    
44.     Dim hModule As Long
    
45.         hModule = GetModuleHandleA(sModule)
    
46.     If (hModule = 0) Then
    
47.         hModule = LoadLibrary(sModule)
    
48.     End If
    
49.     If (hModule) Then
    
50.         If (GetProcAddress(hModule, sFunction)) Then
    
51.             IsFunctionSupported = True
    
52.         End If
    
53.         FreeLibrary hModule
    
54.     End If
    
55. End Function
    
56. 
    
57. Private Sub TrackMouseTracking(hwnd As Long)
    
58.     Dim lpEventTrack As TRACKMOUSEEVENTTYPE
    
59.     With lpEventTrack
    
60.         .cbSize = Len(lpEventTrack)
    
61.         '.dwFlags = &H1 Or &H2  ' TM_HOVER OR TM_LEAVE
    
62.         .dwFlags = &H2
    
63.         .dwHoverTime = 100
    
64.         .hwndTrack = hwnd
    
65.     End With
    
66.     If (m_bIsTrackHandler32) Then
    
67.         TrackMouseEvent lpEventTrack
    
68.     Else
    
69.         TrackMouseEvent2 lpEventTrack
    
70.     End If
    
71. End Sub
    
72. 
    
73. Private Sub UpdateAll()
    
74.     If (m_hWnd <> 0) Then
    
75.         Call InvalidateRect(m_hWnd, ByVal 0, 1)
    
76.     End If
    
77. End Sub

复制代码

ivccav

核心代码。处理WM_MEASUREITEM和WM_DRAWITEM消息，绘制ITEM和SUBITEM的边框和文字。

1. Private Function OnMeasureItem(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long, ByRef bHandled As Boolean) As Long
   
2.     Dim mis As MEASUREITEMSTRUCT
   
3.     OnMeasureItem = 0
   
4.     bHandled = False
   
5.    
   
6.     Call CopyMemory(mis, ByVal lParam, Len(mis))
   
7.    
   
8.     If (mis.CtlType = ODT_LISTVIEW And GetDlgItem(m_hParentWnd, mis.CtlID) = m_hWnd) Then
   
9.         mis.ItemHeight = m_nItemHeight
   
10.         
    
11.         Call CopyMemory(ByVal lParam, mis, Len(mis))
    
12.         
    
13.         bHandled = True
    
14.         OnMeasureItem = 1
    
15.     End If
    
16. End Function
    
17. 
    
18. Private Function OnDrawItem(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long, ByRef bHandled As Boolean) As Long
    
19.     Dim dis As DRAWITEMSTRUCT
    
20.     Dim rcSubItem As RECT, rcHeaderItem As RECT
    
21.    
    
22.     Dim nHeaderItemCount As Long
    
23.     Dim i As Integer
    
24.    
    
25.     OnDrawItem = 0
    
26.     bHandled = False
    
27.    
    
28.     Call CopyMemory(dis, ByVal lParam, Len(dis))
    
29.    
    
30.     If (dis.CtlType = ODT_LISTVIEW And GetDlgItem(m_hParentWnd, dis.CtlID) = m_hWnd) Then
    
31.    
    
32.         ' 获取列表头个数
    
33.         nHeaderItemCount = SendMessage(m_hHeaderWnd, HDM_GETITEMCOUNT, 0, 0)
    
34.         Call SetRect(rcSubItem, dis.rcItem.Left, dis.rcItem.Top, dis.rcItem.Left, dis.rcItem.Bottom)
    
35.             
    
36.         For i = 0 To nHeaderItemCount - 1
    
37.             
    
38.             Call SendMessage(m_hHeaderWnd, HDM_GETITEMRECT, i, rcHeaderItem)
    
39.             
    
40.             rcSubItem.Left = rcSubItem.Right
    
41.             rcSubItem.Right = rcSubItem.Left + rcHeaderItem.Right - rcHeaderItem.Left
    
42.             
    
43.             Call OnDrawSubItem(dis, i, rcSubItem)
    
44.         Next
    
45.     End If
    
46.    
    
47. End Function
    
48. 
    
49. Private Sub OnDrawSubItem(dis As DRAWITEMSTRUCT, ByVal nSubItem As Long, rcSubItem As RECT)
    
50.     Dim hdi As HDITEM
    
51.     Dim li As LVITEM
    
52.     Dim szBuff() As Byte
    
53.     Dim szText As String
    
54.     Dim wTextFormat As Long
    
55.     Dim rcPaint As RECT, rcIntersect As RECT
    
56.     Dim hOldBrush As Long
    
57.     Dim hOldPen As Long
    
58.    
    
59.     Call GetBoundsRect(dis.hdc, rcPaint, 0)
    
60.     If IsRectEmpty(rcPaint) Then
    
61.         Call GetClientRect(m_hWnd, rcPaint)
    
62.     End If
    
63.     Call IntersectRect(rcIntersect, rcPaint, rcSubItem)
    
64.    
    
65.     If Not IsRectEmpty(rcPaint) Then
    
66.    
    
67.         ' 设置绘图边界
    
68.         Call SetBoundsRect(dis.hdc, rcIntersect, DCB_SET)
    
69. 
    
70.         ' 获取列表项文本
    
71.         li.mask = LVIF_TEXT
    
72.         li.iItem = dis.itemID
    
73.         li.iSubItem = nSubItem
    
74.         li.stateMask = -1
    
75.         li.pszText = LocalAlloc(&H40, 255)
    
76.         li.cchTextMax = 255
    
77.         Call SendMessage(m_hWnd, LVM_GETITEMTEXTA, li.iItem, li)
    
78.         
    
79.         szBuff = StrConv(String$(255, 0), vbFromUnicode)
    
80.         Call CopyMemory(szBuff(0), ByVal li.pszText, 255)
    
81.         Call LocalFree(li.pszText)
    
82.         
    
83.         szText = StrConv(szBuff, vbUnicode)
    
84.         szText = Left$(szText, InStr(1, szText, vbNullChar) - 1)
    
85.         
    
86.         ' 获取列表头对齐格式
    
87.         hdi.mask = HDI_FORMAT
    
88.         Call SendMessage(m_hHeaderWnd, HDM_GETITEMA, li.iSubItem, hdi)
    
89.         wTextFormat = DT_LEFT Or DT_VCENTER Or DT_SINGLELINE
    
90.         If (hdi.fmt And HDF_CENTER) Then
    
91.             wTextFormat = wTextFormat Or DT_CENTER
    
92.         ElseIf (hdi.fmt And HDF_RIGHT) Then
    
93.             wTextFormat = wTextFormat Or DT_RIGHT
    
94.         End If
    
95.                
    
96.         ' 填充背景
    
97.         If ShowGird = True Then
    
98.             If (dis.itemState And ODS_SELECTED) Then
    
99.                 hOldBrush = SelectObject(dis.hdc, m_hSelectedItemBkBrush)
    
100.             ElseIf m_bItemBkColorHorizontal = True Then
     
101.                 hOldBrush = SelectObject(dis.hdc, IIf(nSubItem Mod 2, m_hItemBkBrush1, m_hItemBkBrush2))
     
102.             Else
     
103.                 hOldBrush = SelectObject(dis.hdc, IIf(dis.itemID Mod 2, m_hItemBkBrush1, m_hItemBkBrush2))
     
104.             End If
     
105.             hOldPen = SelectObject(dis.hdc, m_hGridPen)
     
106.             Call Rectangle(dis.hdc, rcSubItem.Left, rcSubItem.Top - 1, rcSubItem.Right + 1, rcSubItem.Bottom)
     
107.         Else
     
108.             If (dis.itemState And ODS_SELECTED) Then
     
109.                 Call FillRect(dis.hdc, rcSubItem, m_hSelectedItemBkBrush)
     
110.             ElseIf m_bItemBkColorHorizontal = True Then
     
111.                 Call FillRect(dis.hdc, rcSubItem, IIf(nSubItem Mod 2, m_hItemBkBrush1, m_hItemBkBrush2))
     
112.             Else
     
113.                 Call FillRect(dis.hdc, rcSubItem, IIf(dis.itemID Mod 2, m_hItemBkBrush1, m_hItemBkBrush2))
     
114.             End If
     
115.         End If
     
116.         
     
117.         Call InflateRect(rcSubItem, -1, -1)
     
118.         Call DrawText(dis.hdc, szText, -1, rcSubItem, wTextFormat)
     
119.         Call InflateRect(rcSubItem, 1, 1)
     
120.         
     
121.         ' 还原设备上下文
     
122.         If (hOldBrush <> 0) Then Call SelectObject(dis.hdc, hOldBrush)
     
123.         If (hOldPen <> 0) Then Call SelectObject(dis.hdc, hOldPen)
     
124.         Call SetBoundsRect(dis.hdc, rcPaint, DCB_SET)
     
125.     End If
     
126. End Sub

复制代码

ivccav

连接方法，还有一些属性：

1. Public Function Attach(ByVal hwnd As Long) As Boolean
   
2.     Dim dwNewStyle As Long
   
3.    
   
4.     Attach = False
   
5.     If Not (m_hWnd = 0) Then Exit Function
   
6.    
   
7.     m_hWnd = hwnd
   
8.     m_dwOriginStyle = GetWindowLong(m_hWnd, GWL_STYLE)
   
9.    
   
10.     dwNewStyle = m_dwOriginStyle Or LVS_OWNERDRAWFIXED
    
11.     Call SetWindowLong(m_hWnd, GWL_STYLE, dwNewStyle)
    
12.    
    
13.     m_hHeaderWnd = SendMessage(m_hWnd, LVM_GETHEADER, 0, 0)
    
14.     m_hParentWnd = GetParent(m_hWnd)
    
15.    
    
16.     Call Subclass_Start(m_hWnd)
    
17.     Call Subclass_Start(m_hParentWnd)
    
18.     Call Subclass_AddMsg(m_hWnd, WM_NCDESTROY, MSG_BEFORE)
    
19.     Call Subclass_AddMsg(m_hParentWnd, WM_MEASUREITEM, MSG_BEFORE)
    
20.     Call Subclass_AddMsg(m_hParentWnd, WM_DRAWITEM, MSG_BEFORE)
    
21. 
    
22.     Call UpdateAll
    
23.    
    
24.     Attach = True
    
25. End Function
    
26. 
    
27. Public Function Detach() As Boolean
    
28.     Detach = False
    
29.     If (m_hWnd = 0) Then Exit Function
    
30.    
    
31.     Call SetWindowLong(m_hWnd, GWL_STYLE, m_dwOriginStyle)
    
32.    
    
33.     Call Subclass_StopAll
    
34.    
    
35.    
    
36.     Call UpdateAll
    
37.    
    
38.     m_hWnd = 0
    
39.     m_dwOriginStyle = 0
    
40.    
    
41.     Detach = True
    
42. End Function
    
43. 
    
44. Public Property Get ItemBkColor1() As Long
    
45.     Let ItemBkColor1 = m_clrItemBkColor1
    
46. End Property
    
47. 
    
48. Public Property Let ItemBkColor1(ByVal clr As Long)
    
49.     m_clrItemBkColor1 = clr
    
50.    
    
51.     If (m_hItemBkBrush1 <> 0) Then
    
52.         Call DeleteObject(m_hItemBkBrush1)
    
53.         m_hItemBkBrush1 = 0
    
54.     End If
    
55.     m_hItemBkBrush1 = CreateSolidBrush(m_clrItemBkColor1)
    
56.    
    
57.     Call UpdateAll
    
58. End Property
    
59. 
    
60. Public Property Get ItemBkColor2() As Long
    
61.     Let ItemBkColor2 = m_clrItemBkColor2
    
62. End Property
    
63. 
    
64. Public Property Let ItemBkColor2(ByVal clr As Long)
    
65.     m_clrItemBkColor2 = clr
    
66.    
    
67.     If (m_hItemBkBrush2 <> 0) Then
    
68.         Call DeleteObject(m_hItemBkBrush2)
    
69.         m_hItemBkBrush2 = 0
    
70.     End If
    
71.     m_hItemBkBrush2 = CreateSolidBrush(m_clrItemBkColor2)
    
72.    
    
73.     Call UpdateAll
    
74. End Property
    
75. 
    
76. Public Property Get GridColor() As Long
    
77.     Let GridColor = m_clrGridColor
    
78. End Property
    
79. 
    
80. Public Property Let GridColor(ByVal clr As Long)
    
81.     m_clrGridColor = clr
    
82.    
    
83.     If (m_hGridPen <> 0) Then
    
84.         Call DeleteObject(m_hGridPen)
    
85.         m_hGridPen = 0
    
86.     End If
    
87.     m_hGridPen = CreatePen(PS_SOLID, 1, m_clrGridColor)
    
88.    
    
89.     Call UpdateAll
    
90. End Property
    
91. 
    
92. Public Property Get SelectedItemBkColor() As Long
    
93.     Let SelectedItemBkColor = m_clrSelectedItemBkColor
    
94. End Property
    
95. 
    
96. Public Property Let SelectedItemBkColor(ByVal clr As Long)
    
97.     m_clrSelectedItemBkColor = clr
    
98.    
    
99.     If (m_hSelectedItemBkBrush <> 0) Then
    
100.         Call DeleteObject(m_hSelectedItemBkBrush)
     
101.         m_hSelectedItemBkBrush = 0
     
102.     End If
     
103.     m_hSelectedItemBkBrush = CreateSolidBrush(m_clrSelectedItemBkColor)
     
104.    
     
105.     Call UpdateAll
     
106. End Property
     
107. 
     
108. Public Property Get ItemBkColorHorizontal() As Boolean
     
109.     ItemBkColorHorizontal = m_bItemBkColorHorizontal
     
110. End Property
     
111. 
     
112. Public Property Let ItemBkColorHorizontal(ByVal b As Boolean)
     
113.     m_bItemBkColorHorizontal = b
     
114.     Call UpdateAll
     
115. End Property
     
116. 
     
117. Public Property Get ItemHeight() As Long
     
118.     ItemHeight = m_nItemHeight
     
119. End Property
     
120. 
     
121. Public Property Let ItemHeight(ByVal n As Long)
     
122.     m_nItemHeight = n
     
123.     Call UpdateAll
     
124. End Property
     
125. 
     
126. Public Property Get ShowGird() As Boolean
     
127.     ShowGird = m_bShowGrid
     
128. End Property
     
129. 
     
130. Public Property Let ShowGird(ByVal b As Boolean)
     
131.     m_bShowGrid = b
     
132.     Call UpdateAll
     
133. End Property

复制代码

ivccav

应用案例。窗体中有一个textbox，一个Listview，是一个模糊查询的通用界面

1. 
   
2. Option Explicit
   
3. 
   
4. Private Type RECT
   
5.         Left                        As Long
   
6.         Top                         As Long
   
7.         Right                       As Long
   
8.         Bottom                      As Long
   
9. End Type
   
10. 
    
11. Private Type WINDOWPOS
    
12.   hwnd                              As Long
    
13.   hWndInsertAfter                   As Long
    
14.   x                                 As Long
    
15.   y                                 As Long
    
16.   cx                                As Long
    
17.   cy                                As Long
    
18.   flags                             As Long
    
19. End Type
    
20. 
    
21. Private Const WM_WINDOWPOSCHANGED   As Long = &H47
    
22. Private Const SWP_NOACTIVATE        As Long = &H10
    
23. Private Const SWP_NOMOVE            As Long = &H2
    
24. Private Const SWP_NOOWNERZORDER     As Long = &H200
    
25. Private Const SWP_NOZORDER          As Long = &H4
    
26. 
    
27. Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" ( _
    
28.     ByVal hwnd As Long, _
    
29.     ByVal wMsg As Long, _
    
30.     ByVal wParam As Long, _
    
31.     lParam As Any) As Long
    
32. Private Declare Function GetWindowRect Lib "user32" ( _
    
33.     ByVal hwnd As Long, _
    
34.     lpRect As RECT) As Long
    
35. Private Declare Function GetParent Lib "user32" ( _
    
36.     ByVal hwnd As Long) As Long
    
37. 
    
38. Private arrdata
    
39. Private Custom_Listview As CCustomListView
    
40. '
    
41. Private Sub UserForm_Initialize()
    
42.     Dim i&, j&
    
43.     TextBox1.ControlTipText = "关键词按销售合约或产品编号模糊查询"
    
44.     arrdata = Sheet1.Range("a1").CurrentRegion
    
45.     With ListView1
    
46.         .View = lvwReport '必选
    
47.         .FullRowSelect = True '必选
    
48.         .Font.Size = 12
    
49.         .LabelEdit = lvwManual
    
50.         .MultiSelect = True
    
51.         .CheckBoxes = True '未实现复选框功能，但可按住ctrl多选
    
52.         .ColumnHeaders.Add , , arrdata(1, 1), 60, lvwColumnLeft
    
53.         
    
54.         For i = 2 To UBound(arrdata, 2)
    
55.             .ColumnHeaders.Add , , arrdata(1, i), 80, lvwColumnCenter
    
56.         Next
    
57.         For i = 2 To UBound(arrdata)
    
58.             With .ListItems.Add
    
59.                 .Text = arrdata(i, 1)
    
60.                 For j = 2 To UBound(arrdata, 2)
    
61.                     .SubItems(j - 1) = arrdata(i, j)
    
62.                 Next
    
63.             End With
    
64.         Next
    
65.     End With
    
66.    
    
67.     Set Custom_Listview = New CCustomListView
    
68.     With Custom_Listview
    
69.         .ItemBkColor1 = &HFFC0C0 '交替换色1，实际用于第2行/列颜色
    
70.         .ItemBkColor2 = &HFDF8F0 '交替换色2，实际用于第1行/列颜色
    
71.         .SelectedItemBkColor = &HABECFC '被选中行的高亮颜色
    
72.         .ItemHeight = 32 '行高设置
    
73.         .ItemBkColorHorizontal = False '为False时隔行换色，True时隔列
    
74.         .ShowGird = True '为True时显示网格线
    
75.         .GridColor = vbRed '设置网格线颜色
    
76.         .Attach ListView1.hwnd
    
77.     End With
    
78.     TextBox1.SetFocus
    
79. End Sub
    
80. 
    
81. Private Sub UserForm_Activate()
    
82.     ListViewRefresh
    
83. End Sub
    
84. 
    
85. Private Sub TextBox1_Change()
    
86.     Dim i As Long, j As Long
    
87.     Dim lstitem As ListItem
    
88.     Dim strKey As String
    
89.     If IsEmpty(arrdata) Then Exit Sub
    
90.     With ListView1
    
91.         For i = 1 To .ColumnHeaders.Count
    
92.             .ColumnHeaders(i).Icon = 0
    
93.         Next
    
94.         .ListItems.Clear '清空原有所有数据
    
95.         For i = 2 To UBound(arrdata)
    
96.             strKey = arrdata(i, 3) & arrdata(i, 5)  '按第3、5列内容为关键词模糊查询
    
97.             If InStr(strKey, UCase(TextBox1)) Then '可以使用Instr，也可以使用Like语句
    
98.                 Set lstitem = .ListItems.Add 'Add方法在Listview最后面添加一行空行
    
99.                 lstitem.Text = arrdata(i, 1) '给新增的空行第一列赋值
    
100.                 For j = 2 To UBound(arrdata, 2)
     
101.                     lstitem.SubItems(j - 1) = arrdata(i, j) '给新增行除第一列之外的其他列赋值，用SubItems属性
     
102.                 Next
     
103.             End If
     
104.         Next
     
105.     End With
     
106.     ListViewRefresh
     
107. End Sub
     
108. 
     
109. '新增的过程。无此过程，控件无法触发WM_MEASUREITEM消息
     
110. '修改行高只能在收到发WM_MEASUREITEM时进行修改
     
111. 
     
112. Private Sub ListViewRefresh()
     
113.     Dim rc As RECT, wp As WINDOWPOS
     
114.     ListView1.Refresh
     
115.     GetWindowRect ListView1.hwnd, rc
     
116.     wp.hwnd = ListView1.hwnd
     
117.     wp.cx = rc.Right - rc.Left
     
118.     wp.cy = rc.Bottom - rc.Top
     
119.     wp.flags = SWP_NOACTIVATE Or SWP_NOMOVE Or SWP_NOOWNERZORDER Or SWP_NOZORDER
     
120.     SendMessage ListView1.hwnd, WM_WINDOWPOSCHANGED, 0, wp
     
121. End Sub
     
122. 
     
123. 
     
124. 
     

复制代码