list.cls

金算盘软件代码

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "List"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
'   LIST类
'   作者：杜剑
'   日期：1998.06.24
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''


''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' MSFlexGrid中第0列隐藏，用于存储ID，第1列用于存储“停用”标志。
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Option Explicit

Private WithEvents mFlex As MSFlexGrid                  '列表MSFlexGrid控件
Attribute mFlex.VB_VarHelpID = -1
Private mcboFindKind As ComboBox                        '查找ComboBox控件
Attribute mcboFindKind.VB_VarHelpID = -1
Private mctlFind As TextBox                             '内容TextBox控件
Private WithEvents mcmdAgain As CommandButton           '再找CommandButton控件
Attribute mcmdAgain.VB_VarHelpID = -1
Private mclsListSet As ListSet                          '列表设置对象

Private mintFindRow As Integer                          '当前选定行
Private mintSortCol As Integer                          '当前排序列
Private mlngShowColWidth  As Long                       '当前所有显示列的宽度
Private mOldCol As Integer                              '先前选定列
Private mblnShowAll As Boolean                          '“全部显示”标志
Private mIsSelChange As Boolean                         '是否当前行转换
Private mIsKeyFind As Boolean                           '击键查找标志
Private mblnFlexNoChange As Boolean                     '不需要处理Flex控件Change事件
Private mblnFindNoChange As Boolean                     '不需要处理Find控件Change事件
Private mblnColDrag As Boolean                          '列交换标志
Private mblnDownFixedRow As Boolean                     '点击固定行标志
Private mblnReSort As Boolean                           '重新排序标志
Private mlngDragOverCol As Long                         '拖动时当前列
Private mlngMouseDownCol As Long                        'MouseDown列
Private mClipRect As RECT                               '裁剪区域矩形，用于列表线重画

Private mblnNoSort As Boolean                           '不排序标志
Private mfrmParent As Form
Private mblnDoForm As Boolean



Public Property Get FlexGrid() As MSFlexGrid
    Set FlexGrid = mFlex
End Property

Public Property Set FlexGrid(ByVal vNewValue As MSFlexGrid)
     Set mFlex = vNewValue
End Property

Public Property Set Parent(ByVal vNewValue As Form)
     Set mfrmParent = vNewValue
     mblnDoForm = True
End Property

Public Property Let DoForm(ByVal vNewValue As Boolean)
    If mfrmParent Is Nothing Then
        mblnDoForm = False
    Else
        mblnDoForm = vNewValue
    End If
End Property

Public Property Get ShowAll() As Boolean
    ShowAll = mblnShowAll
End Property

Public Property Let ShowAll(ByVal vNewValue As Boolean)
    mblnShowAll = vNewValue
End Property

Public Property Set FindKind(ByVal vNewValue As ComboBox)
    Set mcboFindKind = vNewValue
End Property

Public Property Set Find(ByVal vNewValue As TextBox)
    Set mctlFind = vNewValue
End Property

Public Property Set Again(ByVal vNewValue As CommandButton)
    Set mcmdAgain = vNewValue
End Property

Public Property Get SortCol() As Integer
    SortCol = mintSortCol
End Property

Public Property Let SortCol(ByVal vNewValue As Integer)
    mintSortCol = vNewValue
End Property

Public Property Let NoSort(ByVal vNewValue As Boolean)
    mblnNoSort = vNewValue
End Property

Public Property Get ListSet() As ListSet
    Set ListSet = mclsListSet
End Property

Public Property Let FlexNoChange(ByVal vNewValue As Boolean)
    mblnFlexNoChange = vNewValue
End Property

Public Property Get FindNoChange() As Boolean
    FindNoChange = mblnFindNoChange
End Property

Public Property Let FindNoChange(ByVal vNewValue As Boolean)
    mblnFindNoChange = vNewValue
End Property

'重画列表竖线及栏目横线
Public Sub gridLineRefresh()
    Dim intCol As Integer
    Dim intCnt As Integer
    Dim intFixCol As Integer, intCols As Integer
    Dim intRowheight As Integer, lngColWidth As Long
    Dim IsHScroll As Boolean, IsVScroll As Boolean
    Dim intColWidthSum As Integer
    Dim intRowPos As Integer
    Dim intWidth As Integer, intHeight As Integer
    Dim intDX As Integer, intDY As Integer
    Dim lngWhite As Long, lngBlack As Long
    
    intDX = Screen.TwipsPerPixelX
    intDY = Screen.TwipsPerPixelY
    lngWhite = RGB(255, 255, 255)
    lngBlack = RGB(128, 128, 128)
    
    ISScroll IsHScroll, IsVScroll
    
    With mFlex
        If IsVScroll Then
            intWidth = .width - gclsEniv.VScrollWidth - ListFormLeft - 30
        Else
            intWidth = .width - 30
        End If
        
        If IsHScroll Then
            intHeight = .Height - gclsEniv.HScrollHeight
        Else
            intHeight = .Height
        End If
        
        mlngShowColWidth = GetShowColWidth(mFlex.Cols - 1)
        mlngShowColWidth = IIf(mlngShowColWidth > intWidth, intWidth, mlngShowColWidth)
        'DrawLine mFlex.hWnd, 0, .RowPos(0) + .RowHeight(0), mlngShowColWidth, .RowPos(0) + .RowHeight(0)
        GridDrawLine mFlex.hwnd, 0, 0, mlngShowColWidth, 0, lngWhite
        
        intRowPos = .RowPos(0) + .RowHeight(0) - intDY
        GridDrawLine mFlex.hwnd, 0, intRowPos, mlngShowColWidth, intRowPos, lngBlack
        '画Grid固定区域竖线
        intRowheight = .RowHeight(0)
        lngColWidth = 0
        intCols = .FixedCols - 1
        GridDrawLine mFlex.hwnd, 0, 0, 0, intRowheight, lngWhite
        For intCnt = 1 To intCols
            lngColWidth = lngColWidth + .ColWidth(intCnt)
            If lngColWidth > intWidth Then
                Exit For
            End If
            GridDrawLine mFlex.hwnd, .ColPos(intCnt) + .ColWidth(intCnt) - 2 * intDX, 0, .ColPos(intCnt) + .ColWidth(intCnt) - 2 * intDX, intHeight, lngBlack
            GridDrawLine mFlex.hwnd, .ColPos(intCnt) + .ColWidth(intCnt) - intDX, 0, .ColPos(intCnt) + .ColWidth(intCnt) - intDX, intRowheight, lngWhite
            If intCnt = intCols Then
                If mclsListSet.Columns > mclsListSet.FixColumns Then    '只有固定列
                    GridDrawLine mFlex.hwnd, .ColPos(intCnt) + .ColWidth(intCnt) - intDX, 0, .ColPos(intCnt) + .ColWidth(intCnt) - intDX, intHeight, lngBlack
                End If
            End If
        Next intCnt
        '画Grid变动区域竖线
        intCol = .LeftCol
        intCols = .Cols - 1
        If intCol < 1 Then intCol = 1
        For intCnt = intCol To intCols
            lngColWidth = lngColWidth + .ColWidth(intCnt)
            If lngColWidth > intWidth Then
                Exit For
            End If
            GridDrawLine mFlex.hwnd, .ColPos(intCnt) + .ColWidth(intCnt) - intDX, 0, .ColPos(intCnt) + .ColWidth(intCnt) - intDX, intHeight, lngBlack
            GridDrawLine mFlex.hwnd, .ColPos(intCnt) + .ColWidth(intCnt), 0, .ColPos(intCnt) + .ColWidth(intCnt), intRowheight, lngWhite
        Next intCnt
    End With
End Sub

'根据裁剪区域画线
Private Sub GridDrawLine(ByVal hwnd As Long, ByVal x1 As Long, ByVal y1 As Long, ByVal x2 As Long, ByVal y2 As Long, ByVal Color As Long)
    Dim hdc As Long
    Dim hPen As Long, hSavePen As Long
    Dim Point As POINTAPI
    Dim blnIsVisible As Boolean
    
    x1 = x1 / Screen.TwipsPerPixelX
    x2 = x2 / Screen.TwipsPerPixelX
    y1 = y1 / Screen.TwipsPerPixelY
    y2 = y2 / Screen.TwipsPerPixelY
    
    '裁减作图区域
    blnIsVisible = True
    With mClipRect
        If x1 = x2 Then
            If (x1 < .Left Or x1 > .Right) Then
                blnIsVisible = False
            ElseIf y1 < .top And y2 < .top Then
                blnIsVisible = False
            ElseIf y1 > .Bottom And y2 > .Bottom Then
                blnIsVisible = False
            Else
                If y1 < .top Then y1 = .top
                If y2 > .Bottom Then y2 = .Bottom
            End If
        ElseIf y1 = y2 Then
            If (y1 < .top Or y1 > .Bottom) Then
                blnIsVisible = False
            ElseIf x1 < .Left And x2 < .Left Then
                blnIsVisible = False
            ElseIf x1 > .Right And x2 > .Right Then
                blnIsVisible = False
            Else
                If x1 < .Left Then x1 = .Left
                If x2 > .Right Then x2 = .Right
            End If
        End If
    End With
    
    If blnIsVisible Then
        hdc = GetDC(hwnd)
        hPen = CreatePen(PS_SOLID, 1, Color)
        hSavePen = SelectObject(hdc, hPen)
        MoveToEx hdc, x1, y1, Point
        LineTo hdc, x2, y2
        SelectObject hdc, hSavePen
        DeleteObject hPen
    
        ReleaseDC hwnd, hdc
    End If
End Sub

'得到当前显示列宽度和
Private Function GetShowColWidth(ByVal intCol As Integer) As Long
    Dim i As Integer
    Dim lngSum As Long
    Dim intCols As Integer
    
    With mFlex
        intCols = .FixedCols - 1
        For i = 0 To intCols
            lngSum = lngSum + .ColWidth(i)
        Next
        intCols = .LeftCol
        For i = intCols To intCol
            lngSum = lngSum + .ColWidth(i)
        Next
    End With
    GetShowColWidth = lngSum
End Function

'初始化FLEXGRID
Public Sub InitFlexGrid()
    With mFlex
        .AllowBigSelection = False
        .AllowUserResizing = flexResizeColumns
        .BorderStyle = flexBorderSingle
        .CellAlignment = flexAlignLeftCenter
        .FocusRect = flexFocusNone
        .GridLinesFixed = flexGridNone
        .GridLines = flexGridNone
        .GridColorFixed = clrWindowBackground
        .BackColorBkg = RGB(255, 255, 255)
        .BackColorFixed = RGB(255, 255, 255)
        .ScrollBars = flexScrollBarBoth
        .SelectionMode = flexSelectionByRow
        .FixedCols = 0
        .Rows = 2
        .FixedRows = 1
        Set .DragIcon = GetFormResPicture(101, vbResIcon)
        Set .MouseIcon = GetFormResPicture(101, vbResCursor)
    End With
End Sub

'设置FLEXGRID
Public Function SetFlexGrid()
    Dim i As Integer
    Dim intCols As Integer
    Dim blnFlexNoChange As Boolean
     
    With mFlex
        If mclsListSet.Columns = mclsListSet.FixColumns Then    '只有固定列
            .FixedCols = mclsListSet.FixColumns + 1
        Else
            .FixedCols = mclsListSet.FixColumns + 2
        End If
        '设置固定行颜色
        mblnFlexNoChange = True
        .Row = 0
        intCols = .Cols - 1
        For i = 0 To intCols
            .col = i
            .CellBackColor = RGB(192, 192, 192)
        Next i
        mblnFlexNoChange = False
        '得到mFlex的列宽,设置列的对齐方式
        For i = 1 To mclsListSet.Columns
            .ColWidth(i + 1) = mclsListSet.ColumnWidth(i)
            Select Case UCase(mclsListSet.ColumnFieldType(i))
                Case "INTEGER", "LONG", "DOUBLE"
                    .ColAlignment(i + 1) = 7
            End Select
        Next i
        If mblnShowAll Then
            .ColWidth(1) = 450
        Else
            .ColWidth(1) = 0
        End If
        .ColWidth(0) = 0
    End With
End Function

'初始化查找复合列表框
Public Function InitcboFindKind() As Integer
    Dim intSortCol As Integer
    Dim intCount As Integer
    Dim intItem As Integer
    
    mcboFindKind.Clear
    For intCount = 1 To mclsListSet.Columns
        If mclsListSet.ColumnIsFind(intCount) Then
            mcboFindKind.AddItem mclsListSet.ColumnDesc(intCount)
            Select Case UCase(mclsListSet.ColumnFieldType(intCount))
                Case "INTEGER", "LONG", "DOUBLE"
                    mcboFindKind.ItemData(intItem) = 1
                Case Else
                    mcboFindKind.ItemData(intItem) = 10 + mclsListSet.ColumnFieldSize(intCount)
            End Select
            
            If mclsListSet.ColumnOrderType(intCount) <> 0 Then
                intSortCol = intItem
                mintSortCol = intCount + 1
                'ozj注释
                If mclsListSet.ColumnOrderType(intCount) = 1 Then
                    mclsListSet.ColumnOrderType(intCount) = 2
                Else
                    mclsListSet.ColumnOrderType(intCount) = 1
                End If
            End If
            intItem = intItem + 1
        End If
    Next
    mcboFindKind.ListIndex = intSortCol
End Function

'处理Hook对象事件
Public Sub HookProc(Msg As Long, wParam As Long, lParam As Long, clsSubClass As SubClass32.SubClass)
    Dim lngX As Long, lngY As Long
    Dim intCount As Integer
    Dim bCancel As Boolean

    bCancel = False
    
    Select Case Msg
        Case WM_LBUTTONDOWN        '鼠标左键按下
            lngX = LoWord(lParam) * Screen.TwipsPerPixelX
            lngY = HiWord(lParam) * Screen.TwipsPerPixelY
            With mFlex
                If lngX < 10 Or lngX > (.ColPos(.Cols - 1) + .ColWidth(.Cols - 1)) Or lngY > .RowPos(.Rows - 1) + .RowHeight(.Rows - 1) Then
                    bCancel = True
                    .ColSel = 0     '光标带消失
                Else
                    If .MouseRow = 0 Then   '点中固定行
                        If lngX < .ColPos(2) + 10 Then  '点中“停用”列，不作处理
                            bCancel = True
                        Else
                            mblnDownFixedRow = True
                            For intCount = 2 To .Cols - 1    '判断是否拖动列宽
                                If lngX < .ColPos(intCount) + .ColWidth(intCount) - 30 And lngX >= .ColPos(intCount) Then
                                    bCancel = True
                                    mOldCol = intCount
                                    mblnColDrag = True
                                    Exit For
                                End If
                            Next
                            mblnReSort = True
                            mintFindRow = .Row
                            mOldCol = .MouseCol
                        End If