tablegrid.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 = "TableGrid"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
'  包装mDBTableCtrl类
'  日期：1999.10.23
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Option Explicit

Const GridNoOrder As Long = 0                                       '没有排序
Const GridAscOrder As Long = 1                                      '升序标志
Const GridDescOrder As Long = 2                                     '降序标志

Const GridUnOrder As Long = 0                                       '不可排序
Const GridOrder As Long = 1                                         '可排序

Private WithEvents mDBTableCtrl As WINCTRLLib.DBTableCtrl
Attribute mDBTableCtrl.VB_VarHelpID = -1
Private mclsListSet As ListSet

Private mResultset As rdoResultset                                     '结果集
Private mlngMaxRows As Long                                         '最大行
Private mlngMaxCols As Long                                         '最大列
Private mlngColOfs As Long                                          '列偏移
Private mintSortCol As Integer                                      '当前排序列
Private mintSortType As Integer                                     '升序或降序
Private mblnEmpty As Boolean

Private mlngEndFormatRow As Long                                    '格式单元参数
Private mintTargetCnt As Integer
Private mintTargetCol() As Integer
Private mintTargetColDec() As Integer
Private mintTargetColType() As Integer
Private mintSourceCol1() As Integer
Private mintSourceCol2() As Integer
Private mstrOperand() As String

Public Event RefreshRecord(blnSucceed As Boolean)
Public Event AfterRefreshGrid()
Public Event AfterRowColChange()


'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' 公有属性
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'PictureBox窗口句柄(只写)
Public Property Let hwnd(ByVal HwndPicture As Long)
    mDBTableCtrl.hwnd = HwndPicture
End Property
'记录集(读写)
Public Property Get Resultset() As rdoResultset
     Set Resultset = mResultset
End Property
Public Property Set Resultset(NewResultset As rdoResultset)
    On Error Resume Next
    mblnEmpty = True
    If Not NewResultset Is Nothing Then
        If Not NewResultset.EOF Then
            mblnEmpty = False
            NewResultset.MoveLast
            Rows = NewResultset.RowCount
        Else
            Rows = 1
        End If
        If Not mResultset Is Nothing Then
            mResultset.Close
            Set mResultset = Nothing
        End If
        Set mResultset = NewResultset
    End If
End Property
'DBTableCtrl(只读)
Public Property Get Grid() As DBTableCtrl
     Set Grid = mDBTableCtrl
End Property
'偏移列数(读写)
Public Property Get ColOfs() As Long
    ColOfs = mlngColOfs
End Property
Public Property Let ColOfs(ByVal NewValue As Long)
    mlngColOfs = NewValue
End Property
'总行数(读写)
Public Property Get Rows() As Long
    Rows = mlngMaxRows
End Property
Public Property Let Rows(ByVal NewValue As Long)
    If NewValue > 0 Then
        mlngMaxRows = NewValue
    Else
        mlngMaxRows = 1
    End If
End Property
'ListSet(只读)
Public Property Get ListSet() As ListSet
    Set ListSet = mclsListSet
End Property
'排序列(读读)
Public Property Get SortCol() As Integer
    SortCol = mintSortCol
End Property
'排序类型: 0 没有排序/ 1 升序/ 2 降序
Public Property Get SortType() As Integer
    SortType = mintSortType
End Property
Public Property Let SortType(ByVal vNewValue As Integer)
    mintSortType = vNewValue
End Property
'表中是否有数据
Public Property Get IsEmpty() As Boolean
     IsEmpty = mblnEmpty
End Property


'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' GRID类私有方法
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Sub Class_Initialize()
    mlngMaxRows = 1
    mblnEmpty = True
    mlngColOfs = 1
    mintTargetCnt = 0
    mlngEndFormatRow = 0
    Set mDBTableCtrl = New WINCTRLLib.DBTableCtrl
    Set mclsListSet = New ListSet
    mclsListSet.FormatSelect = False
End Sub

Private Sub Class_Terminate()
    On Error Resume Next
    If Not mResultset Is Nothing Then
        mResultset.Close
        Set mResultset = Nothing
    End If
    If mclsListSet.ViewId > 0 Then
        GridToListSet
        mclsListSet.SaveList
    End If
    Set mDBTableCtrl = Nothing
    Set mclsListSet = Nothing
End Sub









'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' 公有方法
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'设置Grid表
Public Sub RefreshGrid()
    Dim lngRow  As Long
    Dim lngCol  As Long
    Dim lngRows  As Long
    Dim lngCols  As Long
    Dim lngRowsel  As Long
    Dim lngColsel  As Long
    Dim lngFixedRows As Long
    Dim intCount As Integer
    Dim strTitle As String
    Dim strTitle0 As String
    Dim bytFlag() As Byte
    
'    On Error Resume Next
    
    If mResultset Is Nothing Then
        Exit Sub
    End If
    
    mlngMaxCols = mResultset.rdoColumns.Count
    
    lngFixedRows = 1
    For lngCols = 0 To mlngMaxCols - 1
        intCount = strCount(mResultset.rdoColumns(lngCols).Name, "_") + 1
        If intCount > lngFixedRows Then
             lngFixedRows = intCount
        End If
    Next lngCols
    mlngEndFormatRow = lngFixedRows
    
    With mDBTableCtrl
        .Clear
        .FixedRows = lngFixedRows
        .FixedCols = 0
        .Cols = mlngMaxCols
        .Rows = mlngMaxRows + lngFixedRows
        .Row = lngFixedRows
        For lngCol = 0 To mlngColOfs - 1
            .ColWidth(lngCol) = 0
        Next lngCol
        .RDORecordset = mResultset
    
        .ClipCell = 1
        .SetBorder 0, -1, 1 + 2
        .SetColBorder 0, mlngMaxCols, 1, 0, 2
'        .FixedCols = mlngColOfs + mclsListSet.FixColumns
        .SelectionMode = 4
        .SetOption -1, -1, 0, -1, -1, -1, -1, -1
        .ResizeCol = 1
        
        '设置固定行颜色
        For lngCol = 0 To mlngMaxCols - 1
            .SetCellPattern 0, lngCol, lngFixedRows - 1, lngCol, 0, RGB(192, 192, 192), -1, -1
            .SetCellForeColor 0, 0, lngFixedRows - 1, mlngMaxCols, RGB(0, 0, 0)
            .ColName(lngCol) = mResultset.rdoColumns(lngCol).Name
'            .CellFormula(0, lngCol) = mResultset.Fields(lngCol).Name
        Next
        '得到datagrid的列宽,设置列的对齐方式
        For lngCol = 1 To mclsListSet.Columns
            .ColWidth(mlngColOfs + lngCol - 1) = mclsListSet.ColumnWidth(lngCol) / Screen.TwipsPerPixelX
            Select Case UCase(mclsListSet.ColumnFieldType(lngCol))
                Case "INTEGER", "LONG", "DOUBLE"
                    .SetColAlignment mlngColOfs + lngCol - 1, mlngColOfs + lngCol - 1, 3, 2, -1, -1, -1
                    Select Case mclsListSet.ColumnFormat(lngCol)
                    Case 5
                        .SetColDataType mlngColOfs + lngCol - 1, mlngColOfs + lngCol - 1, 1, 1, gclsBase.NaturalCurDec, -1
                    Case 2
                        .SetColDataType mlngColOfs + lngCol - 1, mlngColOfs + lngCol - 1, 1, 1, gclsBase.PriceDec, -1
                    Case Else
                        .SetColDataType mlngColOfs + lngCol - 1, mlngColOfs + lngCol - 1, 1, 1, mclsListSet.ColumnFieldDec(lngCol), -1
                    End Select
            End Select
        Next lngCol
        
        If lngFixedRows >= 1 Then
            For lngCols = 0 To mlngMaxCols - 1
                strTitle = mResultset.rdoColumns(lngCols).Name
                For lngRows = 0 To .FixedRows - 1
                    If strCount(strTitle, "_") > 0 Then
                        strTitle0 = Left(strTitle, InStr(strTitle, "_") - 1)
                        strTitle = Right(strTitle, Len(strTitle) - Len(strTitle0) - 1)
                    Else
                        strTitle0 = strTitle
                    End If
                    .CellFormula(lngRows, lngCols) = strTitle0
                Next lngRows
            Next lngCols
            
            ReDim bytFlag(lngFixedRows - 1, mlngMaxCols - 1)
            For lngCols = 0 To mlngMaxCols - 1
                For lngRows = 0 To lngFixedRows - 1
                    If bytFlag(lngRows, lngCols) = 0 Then
                        lngColsel = lngCols
                        Do While lngColsel < mlngMaxCols
                            If .CellFormula(lngRows, lngCols) = .CellFormula(lngRows, lngColsel) Then
                                lngColsel = lngColsel + 1
                            Else
                                Exit Do
                            End If
                        Loop
                        lngRowsel = lngRows
                        Do While lngRowsel < lngFixedRows
                            If .CellFormula(lngRows, lngCols) = .CellFormula(lngRowsel, lngCols) Then
                                lngRowsel = lngRowsel + 1
                            Else
                                Exit Do
                            End If
                        Loop
                        For lngCol = lngCols To lngColsel - 1
                            For lngRow = lngRows To lngRowsel - 1
                                If lngCol = lngCols And lngRow = lngRows Then
                                    bytFlag(lngRow, lngCol) = 1
                                Else
                                    bytFlag(lngRow, lngCol) = 2
                                End If
                            Next lngRow
                        Next lngCol
                        .SetCellAlignment lngRows, lngCols, lngRowsel - 1, lngColsel - 1, 2, 1, -1, lngRowsel - lngRows - 1, lngColsel - lngCols - 1
                        If lngRowsel < lngFixedRows Then
                            .SetCellBorder lngRows, lngCols, lngRowsel - 1, lngColsel - 1, 1, RGB(0, 0, 0), 8 + 32
                        Else
                            .SetCellBorder lngRows, lngCols, lngRowsel - 1, lngColsel - 1, 1, RGB(0, 0, 0), 32
                        End If
                    End If
                Next lngRows
            Next lngCols
            For lngCol = 0 To mlngMaxCols - 1
                For lngRow = 0 To lngFixedRows - 1
                    If bytFlag(lngRow, lngCol) = 2 Then
                        .CellFormula(lngRow, lngCol) = ""
                    End If
                Next lngRow
            Next lngCol
        End If
        .SetColBorder mlngColOfs + mclsListSet.FixColumns - 1, mlngColOfs + mclsListSet.FixColumns - 1, 2, 0, 32
        
        '设置排序列
        If mintSortCol > 0 And mintSortCol < mlngMaxCols Then
            If mintSortType = 1 Then
                .CellFormula(0, mintSortCol) = .CellFormula(0, mintSortCol) + "↑"
            ElseIf mintSortType = 2 Then
                .CellFormula(0, mintSortCol) = .CellFormula(0, mintSortCol) + "↓"
            End If
        End If
        RaiseEvent AfterRefreshGrid
        ValidTargetCol
        .Refresh
    End With
End Sub

'查找指定数据
Public Function FindKey(ByVal strKey As String) As String
    Dim lngStart As Long, lngEnd As Long, lngMiddle As Long
    Dim strText As String, dblNumeric As Double, dblKey As Double
    Dim blnIsText As Boolean, intResult As Integer
    Dim blnFind As Boolean
    
    If mintSortType = 0 Or Trim(strKey) = "" Or mintSortCol = 0 Or mintSortCol >= mlngMaxCols Then Exit Function
    
    blnIsText = True
    If mintSortCol >= mlngColOfs Then
        If UCase(mclsListSet.ColumnFieldType(mintSortCol - mlngColOfs + 1)) = "DOUBLE" Or UCase(mclsListSet.ColumnFieldType(mintSortCol - mlngColOfs + 1)) = "LONG" _
            Or UCase(mclsListSet.ColumnFieldType(mintSortCol - mlngColOfs + 1)) = "INTEGER" Then
            blnIsText = False
        End If
    End If