ListView interlaced with different colors Option Explicit
Private enum imageSizingtypes [sizenone] = 0 [sizeCheckbox] [SIZEICON] ENUM
Private Enum LedgerColours vbledgerWhite = & HF9FEFF vbLedgerGreen = & HD0FFCC vbLedgerYellow = & HE1FAFF vbLedgerRed = & HE1E1FF vbLedgerGrey = & HE0E0E0 vbLedgerBeige = & HD9F2F7 vbLedgerSoftWhite = & HF7F7F7 vbledgerPureWhite = & HFFFFFFEnd Enum
'/ * Below used for listview column auto-resizingPrivate Const LVM_FIRST As Long = & H1000Private Const LVM_SETCOLUMNWIDTH As Long = (LVM_FIRST 30) Private Const LVSCW_AUTOSIZE As Long = -1Private 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 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 P icture1 .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 .ster.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 '/ * 5. Text with icons' / * buy by all sizing routines ibarheight =. TextHeight ("W") Select Case NSIningType 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 TEN 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 0Exit Sub SetListViewColor_Error:' / * clear the listview's picture and exit With lv .Picture = Nothing .Refresh End With Resume SetListViewColor_Exit End Subprivate 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 SubPrivate 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 fascist2_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
God, how is it so long? Private submmand3_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 Subprivate Sub loadingData
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 killicon = 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 LvautSizeControl (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, the simple change, but the pic's own height adjustment 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 = lvwRec ORD.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
But in VB, there is no way, but you can set its background image. Previously search for online search to see the article on this article settings the same number of colors, because one picture is sticked by Title Going up), so it seems to be lazy, write it yourself, I really have to write to find that it is very simple.
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 = VBTWIPSPICBG.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.drawidth = 1
'-----------------------------
'Custom.such as
'------------------------------
FOR i = 1 to 33
SET MITEM = lv.listitems
If mitem.checked = false kil
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
Another method Option Explicit
Private enum imageSizingtypes [sizenone] = 0 [sizeCheckbox] [SIZEICON] ENUM
Private Enum LedgerColours vbledgerWhite = & HF9FEFF vbLedgerGreen = & HD0FFCC vbLedgerYellow = & HE1FAFF vbLedgerRed = & HE1E1FF vbLedgerGrey = & HE0E0E0 vbLedgerBeige = & HD9F2F7 vbLedgerSoftWhite = & HF7F7F7 vbledgerPureWhite = & HFFFFFFEnd Enum
'/ * Below used for listview column auto-resizingPrivate Const LVM_FIRST As Long = & H1000Private Const LVM_SETCOLUMNWIDTH As Long = (LVM_FIRST 30) Private Const LVSCW_AUTOSIZE As Long = -1Private 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 ANY) AS Long
Private sub flow_load ()
Command1.Caption = "Text Only" Command2.Caption = "Text && Checks" Command3.Caption = "Text && Icons" End SubPrivate Sub Command1_Click () With ListView1 .Visible = False .Checkboxes = False .FullRowSelect = True Set .SmallIcons = Nothing
Call loaddata (Sizenone) Call setListviewLEDGER (ListView1, _ vbledgellow, _ vblergrey, _ sizenone) .refresh.visible = true '/ * restore visibility end with
End Sub
Private sub fascist2_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 submmand3_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 imagesningtypes)
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.to P - 10000 '/ * Move It Way Off Screen .width = Screen.Width .visible = false .font = lv.font' / * assure pictures1 font matched listView font '/ * match picture box font property' / * with those of Listview with .font .ble = lv.font.bold .charset = lv.font.charset = lv.font.charset = lv.font.charset .italic = lv.font.Name .Name = lv.font.name .strikethrough = lv.font.strikethrough .underline = lv.font . Setline .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' / * buy 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 pictures1.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 = lvwReportSetListViewColor_Exit: On Local Error GoTo 0exit SUB setListViewColor_ERROR:
'/ * clear the listview's picture and exit with lv .picture = Nothing .refresh End with resume setListViewColor_Exit End Sub
Private subloaddata (nsizingtype as imagesiningtypes)
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 killicon = 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 LvautSizeControl (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_usehead Next End Sub
