listview的隔行显示不同颜色 Option Explicit
Private Enum ImageSizingTypes [sizeNone] = 0 [sizeCheckBox] [sizeIcon] End Enum
Private Enum LedgerColours vbledgerWhite = &HF9FEFF vbLedgerGreen = &HD0FFCC vbLedgerYellow = &HE1FAFF vbLedgerRed = &HE1E1FF vbLedgerGrey = &HE0E0E0 vbLedgerBeige = &HD9F2F7 vbLedgerSoftWhite = &HF7F7F7 vbledgerPureWhite = &HFFFFFF End Enum
'/* Below used for listview column auto-resizing Private Const LVM_FIRST As Long = &H1000 Private Const LVM_SETCOLUMNWIDTH As Long = (LVM_FIRST + 30) Private Const LVSCW_AUTOSIZE As Long = -1 Private Const LVSCW_AUTOSIZE_USEHEADER As Long = -2
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 Sub SetListViewLedgerRows(lv As ListView, _ Bar1Color As LedgerColours, _ Bar2Color As LedgerColours, _ nSizingType As ImageSizingTypes, _ Optional nRowsPerBar As Long = 1) Dim iBarHeight As Long '/* height of 1 line in the listview Dim lBarWidth As Long '/* width of listview Dim diff As Long '/* used in calculations of row height Dim twipsy As Long '/* var holding Screen.TwipsPerPixelY iBarHeight = 0 lBarWidth = 0 diff = 0 On Local Error GoTo SetListViewColor_Error twipsy = Screen.TwipsPerPixelY If lv.View = lvwReport Then '/* set up the listview properties With lv .Picture = Nothing '/* clear picture .Refresh .Visible = 1 .PictureAlignment = lvwTile lBarWidth = .Width End With ' lv '/* set up the picture box properties With Picture1 .AutoRedraw = False '/* clear/reset picture .Picture = Nothing .BackColor = vbWhite .Height = 1 .AutoRedraw = True '/* assure image draws .BorderStyle = vbBSNone '/* other attributes .ScaleMode = vbTwips .Top = Form1.Top - 10000 '/* move it way off screen .Width = Screen.Width .Visible = False .Font = lv.Font '/* assure font matches listview font '/* match picture box font properties '/* with those of listview With .Font .Bold = lv.Font.Bold .Charset = lv.Font.Charset .Italic = lv.Font.Italic .Name = lv.Font.Name .Strikethrough = lv.Font.Strikethrough .Underline = lv.Font.Underline .Weight = lv.Font.Weight .Size = lv.Font.Size End With 'Picture1.Font '/* here we calculate the height of each '/* bar in the listview. Several things '/* can affect this height - the use '/* of item icons, the size of those icons, '/* the use of checkboxes and so on through '/* all the permutations. '/* '/* Shown here is code sufficient to calculate '/* this height based on three combinations of '/* data, state icons, and imagelist icons: '/* '/* 1. text only '/* 2. text with checkboxes '/* 3. text with icons '/* used by all sizing routines iBarHeight = .TextHeight("W") Select Case nSizingType Case sizeNone: '/* 1. text only iBarHeight = iBarHeight + twipsy Case sizeCheckBox: '/* 2. text with checkboxes: add to TextHeight the '/* difference between 18 pixels and iBarHeight '/* all calculated initially in pixels, '/* then converted to twips If (iBarHeight \ twipsy) > 18 Then iBarHeight = iBarHeight + twipsy Else diff = 18 - (iBarHeight \ twipsy) iBarHeight = iBarHeight + (diff * twipsy) + twipsy End If Case sizeIcon: '/* 3. text with icons: add to TextHeight the '/* difference between TextHeight and image '/* height, all calculated initially in pixels, '/* then converted to twips. Handles 16x16 icons diff = imagelist1.ImageHeight - (iBarHeight \ twipsy) iBarHeight = iBarHeight + (diff * twipsy) + twipsy End Select '/* since we need two-tone bars, the '/* picturebox needs to be twice as '/* high as the number of rows desired .Height = iBarHeight * (2 * nRowsPerBar) .Width = lBarWidth '/* paint the two bars of color and refresh '/* Note: The line method does not support '/* With/End With blocks Picture1.Line (0, 0)-(lBarWidth, _ (iBarHeight * nRowsPerBar)), Bar1Color, BF Picture1.Line (0, (iBarHeight * nRowsPerBar))-(lBarWidth, _ (iBarHeight * (2 * nRowsPerBar))), Bar2Color, BF .AutoSize = True .Refresh End With 'Picture1 '/* set the lv picture to the '/* Picture1 image lv.Refresh: lv.Picture = Picture1.Image Else lv.Picture = Nothing End If 'lv.View = lvwReport SetListViewColor_Exit: On Local Error GoTo 0 Exit Sub SetListViewColor_Error: '/* clear the listview's picture and exit With lv .Picture = Nothing .Refresh End With Resume SetListViewColor_Exit End Sub
Private Sub Form_Load()
Command1.Caption = "Text Only" Command2.Caption = "Text && Checks" Command3.Caption = "Text && Icons" With Combo1 .AddItem 1 .AddItem 2 .AddItem 3 .AddItem 4 .AddItem 5 .ListIndex = 0 End With End Sub
Private Sub Command1_Click() With ListView1 .Visible = False '/* Slimy workaround for listview redraw problem .Checkboxes = False .FullRowSelect = True .HideSelection = True Set .SmallIcons = Nothing
Call LoadData(sizeNone) Call SetListViewLedgerRows(ListView1, _ vbLedgerYellow, _ vbLedgerGrey, _ sizeNone, _ Combo1.List(Combo1.ListIndex)) .Refresh .Visible = True '/* Restore visibility End With
End Sub
Private Sub Command2_Click()
With ListView1 .Visible = False .Checkboxes = True .FullRowSelect = True Set .SmallIcons = Nothing Call LoadData(sizeCheckBox) Call SetListViewLedgerRows(ListView1, _ vbLedgerYellow, _ vbLedgerGrey, _ sizeCheckBox, _ Combo1.List(Combo1.ListIndex)) .Refresh .Visible = True End With End Sub
天﹐怎么這么長呀。 Private Sub Command3_Click()
With ListView1 .Visible = False .Checkboxes = False .FullRowSelect = True Set .SmallIcons = imagelist1 Call LoadData(sizeIcon) Call SetListViewLedgerRows(ListView1, _ vbLedgerYellow, _ vbLedgerGrey, _ sizeIcon, _ Combo1.List(Combo1.ListIndex)) .Refresh .Visible = True End With Command1.Enabled = False End Sub
Private Sub LoadData(nSizingType As ImageSizingTypes)
Dim cnt As Long Dim itmX As ListItem With ListView1 .ListItems.Clear .ColumnHeaders.Clear .ColumnHeaders.Add , , "Number" .ColumnHeaders.Add , , "Time" .ColumnHeaders.Add , , "User" .ColumnHeaders.Add , , "Tag" .View = lvwReport .Sorted = False End With '/* Create some fake data For cnt = 1 To 100 Set itmX = Form1.ListView1.ListItems.Add(, , Format$(cnt, "###")) If nSizingType = sizeIcon Then itmX.SmallIcon = 1 itmX.SubItems(1) = Format$(Time, "hh:mm:ss am/pm") itmX.SubItems(2) = "RGB-T" itmX.SubItems(3) = "SYS-1234" Next
'/* Now that the control contains data, this '/* causes the columns to resize to fit the items Call lvAutosizeControl(Form1.ListView1) End Sub
Private Sub lvAutosizeControl(lv As ListView)
Dim col2adjust As Long
'/* Size each column based on the maximum of '/* EITHER the columnheader text width, or, '/* if the items below it are wider, the '/* widest list item in the column For col2adjust = 0 To lv.ColumnHeaders.Count - 1 Call SendMessage(lv.hwnd, _ LVM_SETCOLUMNWIDTH, _ col2adjust, _ ByVal LVSCW_AUTOSIZE_USEHEADER)
Next End Sub 來﹐換個簡單的﹐不過pic的高度自己調整 Dim i As Integer, j As Integer, iBarHeight As Integer Dim iFontHeight As Long Dim itemx As ListItem Dim ColHead As ColumnHeader picGreenbar.BackColor = RGB(240, 240, 240) Me.picGreenbar.Height = 510 lvwRecord.View = lvwReport Me.ScaleMode = vbTwips picGreenbar.ScaleMode = vbTwips picGreenbar.BorderStyle = vbBSNone picGreenbar.AutoRedraw = True picGreenbar.Visible = False picGreenbar.Font = lvwRecord.Font iFontHeight = picGreenbar.TextHeight("b") + Screen.TwipsPerPixelY iBarHeight = (iFontHeight * 2) picGreenbar.Width = lvwRecord.Width
picGreenbar.ScaleMode = vbUser picGreenbar.ScaleHeight = 2 picGreenbar.ScaleWidth = 1 ' picGreenbar.Line (0, 0)-(1, 1), vbWhite, BF lvwRecord.PictureAlignment = lvwTile lvwRecord.Picture = picGreenbar.Image Set lvwRecord.SmallIcons = Me.ImageList1
但是在VB中,没有这个方法,但是可以设置它的背景图片,以前在网上搜索看到有关这方面的文章设置背景颜色都是设置相同间隔相同颜色(因为是用一张图片以Title的方式贴上去的),所以看来偷懒不成,自己写吧,真正动手去写才发现原来很简单。
Private Sub SetListItemColor(lv As ListView, picBg As PictureBox)
Dim i As Integer
Dim mItem As ListItem
picBg.BackColor = lv.BackColor
lv.Parent.ScaleMode = vbTwips
picBg.ScaleMode = vbTwips
picBg.BorderStyle = vbBSNone
picBg.AutoRedraw = True
picBg.Visible = False
picBg.Width = lv.Width
picBg.Height = lv.ListItems(1).Height * (lv.ListItems.Count)
picBg.ScaleHeight = lv.ListItems.Count
picBg.ScaleWidth = 1
picBg.DrawWidth = 1
'-----------------------------
'custom.such as
'------------------------------
For i = 1 To 33
Set mItem = lv.ListItems
If mItem.Checked = False Then
If i Mod 2 = 0 Then
picBg.Line (0, i - 1)-(1, i), RGB(254, 209, 199), BF
Else
picBg.Line (0, i - 1)-(1, i), RGB(20, 54, 199), BF
End If
Else
picBg.Line (0, i - 1)-(1, i), RGB(254, 200, 100), BF
End If
Next lv.Picture = picBg.Image
End Sub
另一种方法 Option Explicit
Private Enum ImageSizingTypes [sizeNone] = 0 [sizeCheckBox] [sizeIcon] End Enum
Private Enum LedgerColours vbledgerWhite = &HF9FEFF vbLedgerGreen = &HD0FFCC vbLedgerYellow = &HE1FAFF vbLedgerRed = &HE1E1FF vbLedgerGrey = &HE0E0E0 vbLedgerBeige = &HD9F2F7 vbLedgerSoftWhite = &HF7F7F7 vbledgerPureWhite = &HFFFFFF End Enum
'/* Below used for listview column auto-resizing Private Const LVM_FIRST As Long = &H1000 Private Const LVM_SETCOLUMNWIDTH As Long = (LVM_FIRST + 30) Private Const LVSCW_AUTOSIZE As Long = -1 Private Const LVSCW_AUTOSIZE_USEHEADER As Long = -2
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 Sub Form_Load()
Command1.Caption = "Text Only" Command2.Caption = "Text && Checks" Command3.Caption = "Text && Icons" End Sub
Private Sub Command1_Click() With ListView1 .Visible = False .Checkboxes = False .FullRowSelect = True Set .SmallIcons = Nothing
Call LoadData(sizeNone) Call SetListViewLedger(ListView1, _ vbLedgerYellow, _ vbLedgerGrey, _ sizeNone) .Refresh .Visible = True '/* Restore visibility End With
End Sub
Private Sub Command2_Click()
With ListView1 .Visible = False .Checkboxes = True .FullRowSelect = True Set .SmallIcons = Nothing Call LoadData(sizeCheckBox) Call SetListViewLedger(ListView1, _ vbLedgerYellow, _ vbLedgerGrey, _ sizeCheckBox) .Refresh .Visible = True End With End Sub
Private Sub Command3_Click()
With ListView1 .Visible = False .Checkboxes = False .FullRowSelect = True Set .SmallIcons = imagelist1 Call LoadData(sizeIcon) Call SetListViewLedger(ListView1, _ vbLedgerYellow, _ vbLedgerGrey, _ sizeIcon) .Refresh .Visible = True End With Command1.Enabled = False End Sub
Private Sub SetListViewLedger(lv As ListView, _ Bar1Color As LedgerColours, _ Bar2Color As LedgerColours, _ nSizingType As ImageSizingTypes)
Dim iBarHeight As Long '/* height of 1 line in the listview Dim lBarWidth As Long '/* width of listview Dim diff As Long '/* used in calculations of row height Dim twipsy As Long '/* variable holding Screen.TwipsPerPicture1elY iBarHeight = 0 lBarWidth = 0 diff = 0 On Local Error GoTo SetListViewColor_Error twipsy = Screen.TwipsPerPixelY If lv.View = lvwReport Then '/* set up the listview properties With lv .Picture = Nothing '/* clear picture .Refresh .Visible = 1 .PictureAlignment = lvwTile lBarWidth = .Width End With ' lv '/* set up the picture box properties With Picture1 .AutoRedraw = False '/* clear/reset picture .Picture = Nothing .BackColor = vbWhite .Height = 1 .AutoRedraw = True '/* assure image draws .BorderStyle = vbBSNone '/* other attributes .ScaleMode = vbTwips .Top = Form1.Top - 10000 '/* move it way off screen .Width = Screen.Width .Visible = False .Font = lv.Font '/* assure Picture1 font matched listview font '/* match picture box font properties '/* with those of listview With .Font .Bold = lv.Font.Bold .Charset = lv.Font.Charset .Italic = lv.Font.Italic .Name = lv.Font.Name .Strikethrough = lv.Font.Strikethrough .Underline = lv.Font.Underline .Weight = lv.Font.Weight .Size = lv.Font.Size End With 'Picture1.Font '/* here we calculate the height of each '/* bar in the listview. Several things '/* can affect this height - the use '/* of item icons, the size of those icons, '/* the use of checkboxes and so on through '/* all the permutations. '/* '/* Shown here is code sufficient to calculate '/* this height based on three combinations of '/* data, state icons, and imagelist icons: '/* '/* 1. text only '/* 2. text with checkboxes '/* 3. text with icons '/* used by all sizing routines iBarHeight = .TextHeight("W")
Select Case nSizingType Case sizeNone: '/* 1. text only iBarHeight = iBarHeight + twipsy Case sizeCheckBox: '/* 2. text with checkboxes: add to textheight the '/* difference between 18 Pixels and iBarHeight '/* all calculated initially in Pixels, '/* then converted to twips If (iBarHeight \ twipsy) > 18 Then iBarHeight = iBarHeight + twipsy Else diff = 18 - (iBarHeight \ twipsy) iBarHeight = iBarHeight + (diff * twipsy) + (twipsy * 1) End If Case sizeIcon: '/* 3. text with icons: add to textheight the '/* difference between textheight and image '/* height, all calculated initially in Pixels, '/* then converted to twips. Handles 16x16 icons diff = imagelist1.ImageHeight - (iBarHeight \ twipsy) iBarHeight = iBarHeight + (diff * twipsy) + (twipsy * 1) End Select '/* since we need two-tone bars, the '/* picturebox needs to be twice as high .Height = iBarHeight * 2 .Width = lBarWidth '/* paint the two bars of color and refresh '/* Note: The line method does not support '/* With/End With blocks Picture1.Line (0, 0)-(lBarWidth, iBarHeight), Bar1Color, BF Picture1.Line (0, iBarHeight)-(lBarWidth, iBarHeight * 2), Bar2Color, BF .AutoSize = True .Refresh End With 'Picture1 '/* set the lv picture to the '/* Picture1 image lv.Refresh lv.Picture = Picture1.Image Else lv.Picture = Nothing End If 'lv.View = lvwReport
SetListViewColor_Exit: On Local Error GoTo 0 Exit Sub SetListViewColor_Error:
'/* clear the listview's picture and exit With lv .Picture = nothing .Refresh End With Resume SetListViewColor_Exit End Sub
Private Sub LoadData(nSizingType As ImageSizingTypes)
Dim cnt As Long Dim itmX As ListItem With ListView1 .ListItems.Clear .ColumnHeaders.Clear .ColumnHeaders.Add , , "Number" .ColumnHeaders.Add , , "Time" .ColumnHeaders.Add , , "User" .ColumnHeaders.Add , , "Tag " .View = lvwReport .Sorted = False End With '/* Create some fake data For cnt = 1 To 100 Set itmX = Form1.ListView1.ListItems.Add(, , Format$(cnt, "###")) If nSizingType = sizeIcon Then itmX.SmallIcon = 1 itmX.SubItems(1) = Format$(Time, "hh:mm:ss am/pm") itmX.SubItems(2) = "RGB-T" itmX.SubItems(3) = "SYS-1234" Next
'/* Now that the control contains data, this '/* causes the columns to resize to fit the items Call lvAutosizeControl(Form1.ListView1) End Sub
Private Sub lvAutosizeControl(lv As ListView)
Dim col2adjust As Long
'/* Size each column based on the maximum of '/* EITHER the columnheader text width, or, '/* if the items below it are wider, the '/* widest list item in the column For col2adjust = 0 To lv.ColumnHeaders.Count - 1 Call SendMessage(lv.hwnd, _ LVM_SETCOLUMNWIDTH, _ col2adjust, _ ByVal LVSCW_AUTOSIZE_USEHEADER)
Next End Sub 
|