ctllistviewgraphical.ctl

来自「一个关于电脑管理汽车的软件」· CTL 代码 · 共 1,006 行 · 第 1/3 页

                        LBound(myArray, 2) To new2, _
                        LBound(myArray, 3) To new3) As Currency
                Case "Single()"
                    ReDim arr1(LBound(myArray, 1) To new1, _
                        LBound(myArray, 2) To new2, _
                        LBound(myArray, 3) To new3) As Single
                Case "Double()"
                    ReDim arr1(LBound(myArray, 1) To new1, _
                        LBound(myArray, 2) To new2, _
                        LBound(myArray, 3) To new3) As Double
                Case "Date()"
                    ReDim arr1(LBound(myArray, 1) To new1, _
                        LBound(myArray, 2) To new2, _
                        LBound(myArray, 3) To new3) As Date
                Case "String()"
                    ReDim arr1(LBound(myArray, 1) To new1, _
                        LBound(myArray, 2) To new2, _
                        LBound(myArray, 3) To new3) As String
                Case "Object()"
                    ReDim arr1(LBound(myArray, 1) To new1, _
                        LBound(myArray, 2) To new2, _
                        LBound(myArray, 3) To new3) As Object
                Case "Variant()"
                    ReDim arr1(LBound(myArray, 1) To new1, _
                        LBound(myArray, 2) To new2, _
                        LBound(myArray, 3) To new3) As Variant
            End Select
            For i = LBound(myArray, 1) To _
                IIf(UBound(myArray, 1) < new1, UBound(myArray, 1), new1)
                For j = LBound(myArray, 2) To _
                    IIf(UBound(myArray, 1) < new2, UBound(myArray, 2), new2)
                    For K = LBound(myArray, 3) To _
                        IIf(UBound(myArray, 3) < new3, UBound(myArray, 3), new3)
                        arr1(i, j, K) = myArray(i, j, K)
                    Next
                Next
            Next
        End If
    Case Else
        Msg = "This procedure accepts only 1-D, 2-D, and 3-D arrays."
        MsgBox Msg, 16
End Select
myArray = arr1

End Sub


'*************THIS CONTROLS THE REPAINTING ****************************************

Public Sub RepaintListView()
On Error GoTo errHandler

   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
   Dim currColWidth As Double
   Dim X As Long, Y As Long, Z As Long
   Dim lngRealListWidth As Long
   
   
   Screen.MousePointer = vbHourglass
   
   
   If ListView.ListItems.Count = 0 Then
        ListView.Picture = Nothing
        Screen.MousePointer = vbNormal
        Exit Sub
    End If
    
    If ListView.ColumnHeaders.Count <> UBound(lngListViewColumnSizes) Then
        ' Reset the columns here
        ReDim Preserve lngListViewColumnSizes(ListView.ColumnHeaders.Count)
        ReDim Preserve lngListViewColumnKeys(ListView.ColumnHeaders.Count)
        ReDim Preserve lngListViewPositionLeft(ListView.ColumnHeaders.Count)
        For X = 1 To ListView.ColumnHeaders.Count
            lngListViewColumnSizes(X) = ListView.ColumnHeaders(X).Width
            lngListViewColumnKeys(X) = ListView.ColumnHeaders(X).Position
            lngListViewPositionLeft(ListView.ColumnHeaders(X).Position) = ListView.ColumnHeaders(X).Width
        Next
    End If

   twipsy = Screen.TwipsPerPixelY
   
   lngRealListWidth = 0
   For X = 1 To ListView.ColumnHeaders.Count
     lngRealListWidth = lngRealListWidth + ListView.ColumnHeaders(X).Width
   Next
   
   
                
   With PictureBox
        .Width = lngRealListWidth
        
        .AutoRedraw = False       '/* clear/reset picture
        .Picture = Nothing
        .BackColor = ListView.BackColor
        .AutoRedraw = True
        .BorderStyle = vbBSNone
        .ScaleMode = vbTwips
        '.Visible = False
        .Visible = True
        .Font = ListView.Font
        
        iBarHeight = .TextHeight("W")
        If ListView.Checkboxes Then
                If (iBarHeight \ twipsy) > 18 Then
                  iBarHeight = iBarHeight + twipsy
               Else
                  diff = 18 - (iBarHeight \ twipsy)
                  iBarHeight = iBarHeight + (diff * twipsy) + twipsy
               End If
        Else
                iBarHeight = iBarHeight + twipsy
        End If
        
        If ListView.Height > iBarHeight * ListView.ListItems.Count Then
            .Height = ListView.Height
        Else
            .Height = iBarHeight * ListView.ListItems.Count
        End If
        
        ' ********* DRAW THE COLUMNS BEGIN
               
        For Y = 0 To ListView.ColumnHeaders.Count - 1
                If lngColorColumn(Y + 1) = 0 Then
                    'PictureBox.Line (currColWidth, 0)-(currColWidth + ListView.ColumnHeaders(Y + 1).Width, ListView.Height), _
                                    ListView.BackColor, BF
                Else
                        currColWidth = 0
                        For Z = 1 To ListView.ColumnHeaders(Y + 1).Position - 1
                            currColWidth = Int(currColWidth + lngListViewPositionLeft(Z) - 4)
                                ' I'm not sure why there is a 4 TWIP error per column but there is
                        Next
                        
                    If lngGridLineColorColumn(Y) > 0 Then
                        ' 16 twip correction for the line
                        PictureBox.Line (currColWidth + 16, 0)-(currColWidth + ListView.ColumnHeaders(Y + 1).Width, UserControl.Height), _
                                        lngColorColumn(Y + 1), BF
                    Else
                        PictureBox.Line (currColWidth, 0)-(currColWidth + ListView.ColumnHeaders(Y + 1).Width, UserControl.Height), _
                                        lngColorColumn(Y + 1), BF
                    End If
                End If
                
                If lngGridLineColorColumn(Y + 1) <> 0 Then
                        For Z = 1 To ListView.ColumnHeaders(Y + 1).Position - 1
                            currColWidth = Int(currColWidth + lngListViewPositionLeft(Z) - 4)
                                ' I'm not sure why there is a 4 TWIP error per column but there is
                        Next
                        If lngGridLineColorColumn(Y + 1) < 0 Then
                            ' Left hand side line
                            PictureBox.Line (currColWidth, 0)-(currColWidth, UserControl.Height), _
                                            -lngGridLineColorColumn(Y + 1), B
                        Else
                            ' Right hand side line
                            PictureBox.Line (currColWidth + ListView.ColumnHeaders(Y + 1).Width, 0)-(currColWidth + ListView.ColumnHeaders(Y + 1).Width, UserControl.Height), _
                                            lngGridLineColorColumn(Y + 1), B
                        End If
                
                End If
        Next
        
        ' ********* DRAW THE COLUMNS END
        
        ' ********* DRAW THE ROWS BEGIN
        
        For X = 0 To ListView.ListItems.Count - 1
                If lngColorRow(X + 1) = 0 Then
                    'PictureBox.Line (0, X * iBarHeight)-(ListView.Width, (X + 1) * iBarHeight), _
                                    ListView.BackColor, BF
                Else
                    If lngGridLineColorRow(X) > 0 Then
                            PictureBox.Line (0, (X * iBarHeight) + 8)-(lngRealListWidth, (X + 1) * iBarHeight), _
                                            lngColorRow(X + 1), BF
                    Else
                        PictureBox.Line (0, X * iBarHeight)-(lngRealListWidth, (X + 1) * iBarHeight), _
                                        lngColorRow(X + 1), BF
                    End If
                End If
                
                If lngGridLineColorRow(X + 1) <> 0 Then
                    If lngGridLineColorRow(X + 1) < 0 Then
                        ' Top side line
                        PictureBox.Line (0, X * iBarHeight)-(lngRealListWidth, X * iBarHeight), _
                                        -lngGridLineColorRow(X + 1), B
                    Else
                        ' Bottom side line
                        ' It looks like a 5 twip correction is needed here,
                        ' not sure why...
                         PictureBox.Line (0, ((X + 1) * iBarHeight))-(lngRealListWidth, ((X + 1) * iBarHeight)), _
                                        lngGridLineColorRow(X + 1), B
                    End If
                End If
        Next
        
        ' ********* DRAW THE ROWS END
        
        ' ********* DRAW THE CELLS BEGIN
        
        For Y = 0 To ListView.ColumnHeaders.Count - 1
        
                currColWidth = 0
                For Z = 1 To ListView.ColumnHeaders(Y + 1).Position - 1
                            currColWidth = Int(currColWidth + lngListViewPositionLeft(Z) - 4)
                                ' I'm not sure why there is a 4 TWIP error per column but there is
                Next
        
            For X = 0 To ListView.ListItems.Count - 1
            
            
                If lngColorValue(X + 1, Y + 1) = 0 Then
                    'PictureBox.Line (currColWidth, X * iBarHeight)-(currColWidth + ListView.ColumnHeaders(Y + 1).Width, (X + 1) * iBarHeight), _
                                    ListView.BackColor, BF
                Else
                    PictureBox.Line (currColWidth, X * iBarHeight)-(currColWidth + ListView.ColumnHeaders(Y + 1).Width, (X + 1) * iBarHeight), _
                                    lngColorValue(X + 1, Y + 1), BF
                End If
                
                If lngGridLineColorValue(X + 1, Y + 1) <> 0 Then
                    PictureBox.Line (currColWidth, X * iBarHeight)-(currColWidth + ListView.ColumnHeaders(Y + 1).Width, (X + 1) * iBarHeight), _
                                    lngGridLineColorValue(X + 1, Y + 1), B
                End If
            Next
        Next
        
        ' ********* DRAW THE CELLS END
        
        .Refresh
        
    End With
    
    Screen.MousePointer = vbNormal
    
    ' Debug code
    'ListView.Visible = False
    'Stop
    ListView.Visible = False
    ListView.Picture = PictureBox.Image
    ListView.Visible = True
    

Exit Sub

errHandler:
    If Err.Number <> 480 Then
        MsgBox Err.Description & " " & Err.Number
    End If
        
    Screen.MousePointer = vbNormal
    ' Error number 480 is a memory error that occurs when the listview just gets too big for VB to handle
    ' I do not display this, you'll notice the list view performing oddly -- this is the only indication.
    ' Reduce the size of the list view if you see this.
    ' See: "Can't create AutoRedraw image" MSDN article

End Sub

Public Sub ClearAllColors()
On Error GoTo errHandler
Dim X As Long, Y As Long
    tmrDetectColumnResize.Enabled = True
    
    ReDim lngColorValue(0, 0)
    ReDim lngColorColumn(0)
    ReDim lngColorRow(0)
    ReDim lngGridLineColorRow(0)
    ReDim lngGridLineColorColumn(0)
    ReDim lngGridLineColorValue(0, 0)
    ReDim lngListViewColumnSizes(0)
    ReDim lngListViewColumnKeys(0)
    
    ResizeArray2 lngColorValue, lv.ListItems.Count, lv.ColumnHeaders.Count
    ResizeArray2 lngColorRow, lv.ListItems.Count
    ResizeArray2 lngColorColumn, lv.ColumnHeaders.Count
    ResizeArray2 lngGridLineColorRow, lv.ListItems.Count
    ResizeArray2 lngGridLineColorColumn, lv.ColumnHeaders.Count
    ResizeArray2 lngGridLineColorValue, lv.ListItems.Count, lv.ColumnHeaders.Count
    

Exit Sub

errHandler:
    MsgBox Err.Description & " " & Err.Number

End Sub

Public Sub SetBackColumnColor(lngColumn As Long, lngColor As Long)
On Error GoTo errHandler
Dim X As Long
        tmrDetectColumnResize.Enabled = True

        ResizeArray2 lngColorValue, lv.ListItems.Count, lv.ColumnHeaders.Count
        ResizeArray2 lngColorRow, lv.ListItems.Count
        ResizeArray2 lngColorColumn, lv.ColumnHeaders.Count
        ResizeArray2 lngGridLineColorRow, lv.ListItems.Count
        ResizeArray2 lngGridLineColorColumn, lv.ColumnHeaders.Count
        ResizeArray2 lngGridLineColorValue, lv.ListItems.Count, lv.ColumnHeaders.Count
        
        ' 0 is used to indicate no painting is necessary, so we need to go ahead and
        ' set any 0 values to "1", which is almost black :)
        If lngColor = 0 Then lngColor = 1
        
        ' -1 is used to reset the paint value
        If lngColor = -1 Then lngColor = 0
        
        If lngColorColumn(lngColumn) <> lngColor Then
            lngColorColumn(lngColumn) = lngColor
            blnRepaintScreen = True
        End If
        

Exit Sub

errHandler:
    MsgBox Err.Description & " " & Err.Number

End Sub

Public Sub SetBackRowColor(lngRow As Long, lngColor As Long)
On Error GoTo errHandler
Dim X As Long
        tmrDetectColumnResize.Enabled = True

        ResizeArray2 lngColorValue, lv.ListItems.Count, lv.ColumnHeaders.Count
        ResizeArray2 lngColorRow, lv.ListItems.Count
        ResizeArray2 lngColorColumn, lv.ColumnHeaders.Count
        ResizeArray2 lngGridLineColorRow, lv.ListItems.Count
        ResizeArray2 lngGridLineColorColumn, lv.ColumnHeaders.Count
        ResizeArray2 lngGridLineColorValue, lv.ListItems.Count, lv.ColumnHeaders.Count
        
        ' 0 is used to indicate no painting is necessary, so we need to go ahead and
        ' set any 0 values to "1", which is almost black :)
        If lngColor = 0 Then lngColor = 1
        
        ' -1 is used to reset the paint value
        If lngColor = -1 Then lngColor = 0