给listview的各行设置不同的颜色

来源:互联网 发布:非农数据影响什么 编辑:程序博客网 时间:2024/06/11 06:41

Public Sub SetListViewColor(ByRef LV As ListView)
'' ==========================================================
'     开发人员:段利庆
'     编写时间:06-12-05
'     过程名称:SetListViewColor
'     参数说明:Lv      ListView
'               picBg   PictureBox
'
'     功能说明:美化<ListView> 列表隔行显示两种颜色
'         注意:绘图用的<PictureBox>是临时生成的,使用后就会销毁
'
'               在使用这个功能的窗体<Form_Load>事件,
'               必须定义<LISTVIEW>和<隐藏的图片框>所在的窗体
'               Set objData.FrmName = Me
'' ==========================================================

'*中央错误处理
On Error GoTo PROC_ERR
   
    '*可能出先窗体载入<pic>时。已经加载的还没有卸载
    '*原因是在一个窗体上使用了两个 <ListView>
    'On Error Resume Next

    '如果不是LISTVIEW对象使用的是报表视图
    If Not LV.View = lvwReport Then
         '设置LISTVIEW 的图片属性 等于 空
        Set LV.Picture = Nothing
        GoTo PROC_EXIT
    End If
   
    Dim picBg As PictureBox
   
    '定义一个对象变量,类型是PictureBox
    '从FrmName这个属性得到要载入这个PictureBox的窗体名称
    '并在这个窗体上载入一个PictureBox
    'PictureBox的名字是“PIC”
    Set picBg = FrmName.Controls.Add("VB.PictureBox", "pic")

    '*清除原来绘制的颜色
    Set LV.Picture = Nothing
   
    If LV.ListItems.Count = 0 Then
        GoTo PROC_EXIT
    End If
   
    Dim LastCmd As Integer
    Dim i As Integer
    LastCmd = 2
   
    '设置 CtlPicBox 这个对象的属性
    With picBg
        .BackColor = LV.BackColor
        .ScaleMode = vbTwips
        .BorderStyle = vbBSNone
        .AutoRedraw = True
        .Visible = False
   
   
   
        If LV.Width < LV.ListItems.Item(1).Width Then
            .Width = LV.ListItems.Item(1).Width
        Else
            .Width = LV.Width
        End If
       
        .Height = LV.ListItems(1).Height * (LV.ListItems.Count)
        .ScaleHeight = LV.ListItems.Count
        .ScaleWidth = 1
        .DrawWidth = 1
        .Cls
    End With
   
    For i = 1 To LV.ListItems.Count
       If i Mod 2 = 0 Then
         picBg.Line (0, i - 1)-(1, i), &HFFFFC0, BF
       Else
         picBg.Line (0, i - 1)-(1, i), &HFFC0C0, BF
       End If
    Next
   

    LV.Picture = picBg.Image
   
    '从窗体上删除用来画线的不可见图片框
    FrmName.Controls.Remove "pic"


PROC_EXIT:
    Exit Sub
   
PROC_ERR:
       
    MsgBox "     ErrNumber: " & Err.Number & vbCrLf & _
           "ErrDescription: " & Err.Description & vbCrLf & _
           "        Module: " & "ClsData" & vbCrLf & _
           "     Procedure: " & "SetListViewColor", vbExclamation
   
    GoTo PROC_EXIT
End Sub
 

原创粉丝点击