|
|
实现Listview控件隔行更换背景色的主流方法是利用VB6中的picturebox控件在VBA窗体中绘制图片，模拟背景色的效果。这种方法的缺点非常明显，例如需要安装一个DLL控件才能使用picturebox，且受限于picturebox的高度，只能绘制600多行数据范围的背景图，超过600行就没有办法绘制了。相关内容可看：
知识树：VBA下用的PictureBox控件(ListView隔行不同颜色轻松显示)
如果数据量比较大，ListView隔行不同颜色显示出现故障
我在VBA窗体Listview控件完全教程 帖中给出了一个完美的办法，利用事先保存的图片做背景图片，模拟隔行换色的效果，功能上十分完美，能显示任何行数的数据，但是因为没有使用任何代码，只是巧妙地利用了Listview的某个属性，显得没有技术含量。内心一直想要实现Listview原生修改行列背景色的功能。
一个月前，偶然看到别人的一个提问：怎么在Listview中对特定行、列进行背景颜色和字体颜色的修改，知道了CUSTOMDRAW重绘技术，隐约觉得可以挪到VBA中。别人的提问如下：
if ( CDDS_PREPAINT == pLVCD->nmcd.dwDrawStage )
{
*pResult = CDRF_NOTIFYITEMDRAW;
}
else if ( CDDS_ITEMPREPAINT == pLVCD->nmcd.dwDrawStage )
{
*pResult = CDRF_NOTIFYSUBITEMDRAW;
}
else if ( (CDDS_ITEMPREPAINT | CDDS_SUBITEM) == pLVCD->nmcd.dwDrawStage )
{
//这里改变背景和字体颜色
*pResult = CDRF_NOTIFYPOSTPAINT;
}
else if ( CDDS_ITEMPOSTPAINT == pLVCD->nmcd.dwDrawStage )
{
//在这里进行画图，但怎么都无法进入
}
搜索CUSTOMDRAW，很遗憾，相关技术很少，而应用到VBA中的则没有任何搜索结果。于是我只好硬着头皮阅读C++代码。说实在的，C++是10多年前学过的东西，现在连语法符合都不认识了。没办法，只能以时间换空间，有空就研究几句，并在微软官网啃食英文文档，慢慢理解了重绘的原理和过程，并在学习过程中，逐渐找到非常珍贵的几条VB语言的相似内容，东拼西凑，东改西改，终于搞成功了：实现了Listview任意行、任意列、任意单元格的前景色和背景色的更改。
CUSTOMDRAW是一个强大而高效的技术，不仅能更改Listview行、列的前景色和背景色，还能更改Listview标题行的前景色和背景色，甚至Listview网格线颜色，还可以应用到其他列表控件。言归正传，以下为我“研究”的成果图和源代码，并附上部分资料（我翻译水平差，请以原文原义为准）：
特别提示：窗口过程函数要求传递的Listview控件的父窗体句柄不是Userform1的句柄，而是Userform1的客户区窗口句柄。我开始没搞明白，一直都没有变化，差点放弃了，还好用SPY++看了一下。
模块中代码：
- Public Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
- Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
- Public Const NM_CUSTOMDRAW = (-12&)
- Public Const WM_NOTIFY As Long = &H4E&
- Public Const CDDS_PREPAINT As Long = &H1&
- Public Const CDRF_NOTIFYITEMDRAW As Long = &H20&
- Public Const CDRF_NOTIFYSUBITEMDRAW As Long = &H20&
- Public Const CDDS_ITEM As Long = &H10000
- Public Const CDDS_SUBITEM As Long = &H20000
- Public Const CDDS_ITEMPREPAINT As Long = CDDS_ITEM Or CDDS_PREPAINT
- Public Const CDRF_NEWFONT As Long = &H2&
- Public Type NMHDR
- hWndFrom As Long
- idFrom As Long
- code As Long
- End Type
- Public Type RECT
- Left As Long
- Top As Long
- Right As Long
- Bottom As Long
- End Type
- Public Type NMCUSTOMDRAW
- hdr As NMHDR
- dwDrawStage As Long
- hDC As Long
- rc As RECT
- dwItemSpec As Long
- uItemState As Long
- lItemlParam As Long
- End Type
- Public Type NMLVCUSTOMDRAW
- nmcd As NMCUSTOMDRAW
- clrText As Long
- clrTextBk As Long
- iSubItem As Long
- End Type
- Public PreWndProc As Long
- Public Function WindowProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
- Select Case uMsg
- Case WM_NOTIFY
- Dim tNMHDR As NMHDR
- CopyMemory tNMHDR, ByVal lParam, Len(tNMHDR)
- With tNMHDR
- If .code = NM_CUSTOMDRAW Then
- Dim tNMLVCUSTOMDRAW As NMLVCUSTOMDRAW
- CopyMemory tNMLVCUSTOMDRAW, ByVal lParam, Len(tNMLVCUSTOMDRAW)
- With tNMLVCUSTOMDRAW.nmcd
- Select Case .dwDrawStage
- Case CDDS_PREPAINT
- WindowProc = CDRF_NOTIFYITEMDRAW
- Exit Function
- Case CDDS_ITEMPREPAINT
- WindowProc = CDRF_NOTIFYSUBITEMDRAW
- Exit Function
- Case CDDS_ITEMPREPAINT Or CDDS_SUBITEM
- Dim iItem&, iSubItem&
- iItem = .dwItemSpec + 1 '行号
- iSubItem = tNMLVCUSTOMDRAW.iSubItem + 1 '列号
-
- tNMLVCUSTOMDRAW.clrText = IIf(iSubItem Mod 2, vbRed, vbBlue) '奇数列红色，偶数列蓝色，也可任意设置
- tNMLVCUSTOMDRAW.clrTextBk = IIf(iSubItem Mod 2, RGB(187, 255, 255), RGB(255, 211, 155))
-
- ' tNMLVCUSTOMDRAW.clrText = IIf(iItem Mod 2, vbRed, vbBlue) '奇数行红色，偶数行蓝色，也可任意设置
- ' tNMLVCUSTOMDRAW.clrTextBk = IIf(iItem Mod 2, RGB(187, 255, 255), RGB(255, 211, 155))
-
- ' tNMLVCUSTOMDRAW.clrText = IIf(iItem = iSubItem, vbRed, vbBlue) '对角线上的单元格：红色，也可设置任意单元格
- ' tNMLVCUSTOMDRAW.clrTextBk = IIf(iItem = iSubItem, RGB(187, 255, 255), RGB(255, 211, 155))
-
- CopyMemory ByVal lParam, tNMLVCUSTOMDRAW, Len(tNMLVCUSTOMDRAW)
- WindowProc = CDRF_NEWFONT
- Exit Function
- End Select
- End With
- End If
- End With
- End Select
- WindowProc = CallWindowProc(PreWndProc, hwnd, uMsg, wParam, lParam)
- End Function
窗体中代码：
- Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
- Private Declare Function GetParent Lib "user32" (ByVal hwnd As Long) As Long
- Private Const GWL_WNDPROC As Long = (-4&)
- Private hWndLVParent As Long
- Private Sub UserForm_Initialize()
- Dim i&, j&
- With ListView1
- .View = lvwReport
- .FullRowSelect = True
- .LabelEdit = lvwManual
- .Gridlines = True
- .SmallIcons = ImageList1
- .Font.Size = 12
- For i = 1 To 20
- .ColumnHeaders.Add , , "第" & i & "列", 50
- Next
-
- For i = 1 To 20
- With .ListItems.Add(, , Format(i, "00-") & "01")
- For j = 1 To 19
- .SubItems(j) = Format(i, "00-") & Format(j + 1, "00")
- Next
- End With
- Next
- hWndLVParent = GetParent(.hwnd)
- End With
- PreWndProc = SetWindowLong(hWndLVParent, GWL_WNDPROC, AddressOf WindowProc)
- End Sub
- Private Sub UserForm_Terminate()
- SetWindowLong hWndLVParent, GWL_WNDPROC, PreWndProc
- End Sub
源代码和部分资料.zip
(184.49 KB, 下载次数: 1131)
补充内容 (2023-3-25 13:39):
纯代码实现窗体Listview控件网格线颜色、行高和选中行颜色的设置
https://club.excelhome.net/thread-1657761-1-1.html
补充内容 (2023-5-17 16:56):
Listview虚拟模式极速显示100000000行大数据的实现
https://club.excelhome.net/thread-1662904-1-1.html |
评分
-
10
查看全部评分
-
|
[复制链接]
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2018-8-3 18:54
楼主
