ctllistviewgraphical.ctl

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

VERSION 5.00
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MsComCtl.ocx"
Begin VB.UserControl ctlListViewGraphical 
   ClientHeight    =   2760
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   3465
   ScaleHeight     =   2760
   ScaleWidth      =   3465
   Begin VB.Timer tmrDetectColumnResize 
      Enabled         =   0   'False
      Interval        =   100
      Left            =   1380
      Top             =   1020
   End
   Begin MSComctlLib.ListView ListView 
      Height          =   2775
      Left            =   0
      TabIndex        =   1
      Top             =   0
      Width           =   3495
      _ExtentX        =   6165
      _ExtentY        =   4895
      View            =   3
      LabelEdit       =   1
      LabelWrap       =   -1  'True
      HideSelection   =   0   'False
      AllowReorder    =   -1  'True
      FullRowSelect   =   -1  'True
      _Version        =   393217
      ForeColor       =   -2147483640
      BackColor       =   -2147483643
      BorderStyle     =   1
      Appearance      =   1
      NumItems        =   0
   End
   Begin VB.PictureBox PictureBox 
      Height          =   195
      Left            =   0
      ScaleHeight     =   135
      ScaleWidth      =   495
      TabIndex        =   0
      Top             =   0
      Visible         =   0   'False
      Width           =   555
   End
End
Attribute VB_Name = "ctlListViewGraphical"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

'***************************DECLARATIONS**************************************

Private hHeader As Long   '/* handle to the listview columnheader
Private blnPaintInitialized As Boolean
Private lngColorValue() As Long
Private lngColorColumn() As Long
Private lngColorRow() As Long
Private lngGridLineColorColumn() As Long
Private lngGridLineColorRow() As Long
Private lngGridLineColorValue() As Long
Private lngListViewColumnSizes() As Double
Private lngListViewColumnKeys() As Long
Private lngListViewPositionLeft() As Double
Private blnRepaintScreen As Boolean

Private mVerticalScrollBarPosition As Long
Private mHorizontalScrollBarPosition As Long

Private HideColumnList() As Long

Private Enum ImageSizingTypes
   [sizeNone] = 0
   [sizeCheckBox]
   [sizeIcon]
End Enum

' Extending the listview events...

Event cClick()
Event cColumnClick(ByVal ColumnHeader As MSComctlLib.ColumnHeader)
Event cDblClick()
Event cItemCheck(ByVal Item As MSComctlLib.ListItem)
Event cItemClick(ByVal Item As MSComctlLib.ListItem)

Event ListViewHasBeenResized()
Event ListViewHasColumnsChanged()

Event VerticalScrollBarListViewPositionChanged(lngNewPosition As Long)
Event HorizontalScrollBarListViewPositionChanged(lngNewPosition As Long)

Private Declare Function GetScrollInfo Lib "user32" (ByVal hWnd As Long, ByVal n As Long, lpScrollInfo As SCROLLINFO) As Long

Private Type SCROLLINFO
    cbSize As Long
    fMask As Long
    nMin As Long
    nMax As Long
    nPage As Long
    nPos As Long
    nTrackPos As Long
End Type


Private Const SIF_RANGE = &H1
Private Const SIF_PAGE = &H2
Private Const SIF_POS = &H4
Private Const SIF_DISABLENOSCROLL = &H8
Private Const SIF_TRACKPOS = &H10
Private Const SIF_ALL = (SIF_RANGE Or SIF_PAGE Or SIF_POS Or SIF_TRACKPOS)

Private Const SB_LINEDOWN = 1
Private Const SB_CTL = 2
Private Const SB_HORZ = 0
Private Const SB_VERT = 1


Private Function GetListViewScrollPosition()
    Dim SI As SCROLLINFO
    Dim ans As Long
    
    SI.cbSize = Len(SI)
    SI.fMask = SIF_RANGE Or SIF_POS
    
    ans = GetScrollInfo(Me.lv.hWnd, SB_VERT, SI)
    
    If SI.nPos <> Me.VerticalScrollBarPosition Then
        Me.VerticalScrollBarPosition = SI.nPos
        RaiseEvent VerticalScrollBarListViewPositionChanged(Me.VerticalScrollBarPosition)
    End If
    
    ans = GetScrollInfo(Me.lv.hWnd, SB_HORZ, SI)
    
    If SI.nPos <> Me.HorizontalScrollBarPosition Then
        Me.HorizontalScrollBarPosition = SI.nPos
        RaiseEvent HorizontalScrollBarListViewPositionChanged(Me.HorizontalScrollBarPosition)
    End If
 
    'Debug.Print SI.nMax
    'Debug.Print SI.nTrackPos
    'Debug.Print SI.cbSize
    

End Function


Public Property Get Height() As Long
    Height = UserControl.Height
End Property

Public Property Let Height(vHeight As Long)
    UserControl.Height = vHeight
End Property

Public Property Get Width() As Long
    Width = UserControl.Width
End Property

Public Property Let Width(vWidth As Long)
    UserControl.Width = vWidth
End Property

Public Property Get lv() As ListView
    Set lv = UserControl.ListView
End Property

Public Property Get VerticalScrollBarPosition() As Long
    VerticalScrollBarPosition = mVerticalScrollBarPosition
End Property

Public Property Let VerticalScrollBarPosition(vVerticalScrollBarPosition As Long)
    mVerticalScrollBarPosition = vVerticalScrollBarPosition
End Property


Public Property Get HorizontalScrollBarPosition() As Long
    HorizontalScrollBarPosition = mHorizontalScrollBarPosition
End Property

Public Property Let HorizontalScrollBarPosition(vHorizontalScrollBarPosition As Long)
    mHorizontalScrollBarPosition = vHorizontalScrollBarPosition
End Property

' ************************** EXTEND SOME OF THE LISTVIEW EVENTS *****************
Private Sub ListView_Click()
    If Ambient.UserMode Then RaiseEvent cClick
End Sub

Private Sub ListView_ColumnClick(ByVal ColumnHeader As MSComctlLib.ColumnHeader)
    If Ambient.UserMode Then RaiseEvent cColumnClick(ColumnHeader)
End Sub

Private Sub ListView_DblClick()
    If Ambient.UserMode Then RaiseEvent cDblClick
End Sub


Private Sub ListView_ItemCheck(ByVal Item As MSComctlLib.ListItem)
    If Ambient.UserMode Then RaiseEvent cItemCheck(Item)
End Sub

Private Sub ListView_ItemClick(ByVal Item As MSComctlLib.ListItem)
    If Ambient.UserMode Then RaiseEvent cItemClick(Item)
End Sub


'*******************END LISTVIEW Event cEXTENSIONS***********************************


Private Sub ResizeArray2(ByRef myArray As Variant, _
                ByVal new1 As Long, _
                Optional ByVal new2, _
                Optional ByVal new3)

'ReDim Preserve can be used to change the size of
'only the last dimension of an array while
'preserving its values; this Sub procedure, while
'preserving the values of the array that is passed
'to it, will change the size of any or all of the
'dimensions of a one-, two- or three-dimensional array.
'Its arguments are the array and its new dimensions.

Dim arr1, i As Long, j As Long, K As Long, Msg As String
Dim NumDimensions As Integer, P As Integer, Z As Integer

'Insure that an array is passed to this Sub procedure
If Not IsArray(myArray) Or IsObject(myArray) Then
    MsgBox "The first argument passed to this " & _
    "procedure must be an array"
    Exit Sub
End If

'Establish the number of dimensions of the input array
On Error Resume Next
P = 1
Do
    Z = UBound(myArray, P)
    P = P + 1
Loop While Err = 0
On Error GoTo 0
NumDimensions = P - 2

Select Case NumDimensions
    Case 1
        ReDim Preserve myArray(LBound(myArray, 1) To new1)
        Exit Sub
    Case 2
        If IsMissing(new2) Then
            Msg = "The second argument is not optional for this case."
            MsgBox Msg, 16
            Exit Sub
        End If
        If new1 = UBound(myArray, 1) Then
            ReDim Preserve myArray(LBound(myArray, 1) To new1, _
                LBound(myArray, 2) To new2)
            Exit Sub
        Else
            Select Case TypeName(myArray)
                Case "Byte()"
                    ReDim arr1(LBound(myArray, 1) To new1, _
                        LBound(myArray, 2) To new2) As Byte
                Case "Boolean()"
                    ReDim arr1(LBound(myArray, 1) To new1, _
                        LBound(myArray, 2) To new2) As Boolean
                Case "Integer()"
                    ReDim arr1(LBound(myArray, 1) To new1, _
                        LBound(myArray, 2) To new2) As Integer
                Case "Long()"
                    ReDim arr1(LBound(myArray, 1) To new1, _
                        LBound(myArray, 2) To new2) As Long
                Case "Currency()"
                    ReDim arr1(LBound(myArray, 1) To new1, _
                        LBound(myArray, 2) To new2) As Currency
                Case "Single()"
                    ReDim arr1(LBound(myArray, 1) To new1, _
                        LBound(myArray, 2) To new2) As Single
                Case "Double()"
                    ReDim arr1(LBound(myArray, 1) To new1, _
                        LBound(myArray, 2) To new2) As Double
                Case "Date()"
                    ReDim arr1(LBound(myArray, 1) To new1, _
                        LBound(myArray, 2) To new2) As Date
                Case "String()"
                    ReDim arr1(LBound(myArray, 1) To new1, _
                        LBound(myArray, 2) To new2) As String
                Case "Object()"
                    ReDim arr1(LBound(myArray, 1) To new1, _
                        LBound(myArray, 2) To new2) As Object
                Case "Variant()"
                    ReDim arr1(LBound(myArray, 1) To new1, _
                        LBound(myArray, 2) To new2) 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, 2) < new2, UBound(myArray, 2), new2)
                    arr1(i, j) = myArray(i, j)
                Next
            Next
        End If
    Case 3
        If IsMissing(new2) Or IsMissing(new3) Then
            Msg = "The second and third arguments " & _
                "are not optional for this case."
            MsgBox Msg, 16
            Exit Sub
        End If
        If new1 = UBound(myArray, 1) And new2 = _
            UBound(myArray, 2) Then
            ReDim Preserve myArray(LBound(myArray, 1) _
                To new1, LBound(myArray, 2) To new2, _
                LBound(myArray, 3) To new3)
            Exit Sub
        Else
            Select Case TypeName(myArray)
                Case "Byte()"
                    ReDim arr1(LBound(myArray, 1) To new1, _
                        LBound(myArray, 2) To new2, _
                        LBound(myArray, 3) To new3) As Byte
                Case "Boolean()"
                    ReDim arr1(LBound(myArray, 1) To new1, _
                        LBound(myArray, 2) To new2, _
                        LBound(myArray, 3) To new3) As Boolean
                Case "Integer()"
                    ReDim arr1(LBound(myArray, 1) To new1, _
                        LBound(myArray, 2) To new2, _
                        LBound(myArray, 3) To new3) As Integer
                Case "Long()"
                    ReDim arr1(LBound(myArray, 1) To new1, _
                        LBound(myArray, 2) To new2, _
                        LBound(myArray, 3) To new3) As Long
                Case "Currency()"
                    ReDim arr1(LBound(myArray, 1) To new1, _