newgrid.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 = "NewGrid"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
'  GRID类
'  作者：黄涛
'  日期：1998.06.03
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' MSFlexGrid中第0列隐藏，用于存储ID。
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Option Explicit

Const GridReadWrite As Long = 1                                     '读写标志
Const GridReadOnly As Long = 0                                      '只读标志

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                                         '可排序

Const GridTextType As Long = 0                                      '字符类型
Const GridNumericType As Long = 1                                   '数值类型

Private WithEvents mclsSubClassFlex As SubClass32.SubClass          'SubClass对象：处理MSFlexGrid对象
Attribute mclsSubClassFlex.VB_VarHelpID = -1
Private WithEvents mclsSubClassText As SubClass32.SubClass          'SubClass对象：处理MSFlexGrid对象
Attribute mclsSubClassText.VB_VarHelpID = -1
Private WithEvents mFlex As MSFlexGrid                              'MSFlexGrid对象
Attribute mFlex.VB_VarHelpID = -1
Private WithEvents mclsHook As SubClass32.SubClass     '窗体回调函数对象
Attribute mclsHook.VB_VarHelpID = -1
Private frmName As Form
Private FormClipRect As RECT
Private GridClipRect As RECT
Private mclsListSet As ListSet                                      'Grid数据对象

Private mClipRect As RECT                                           'Paint事件矩形区域
Private hdc As Long                                                 'Grid hDC

Private mlngColOfs As Long                                          'Grid中ListSet列开始位置

Private mlngSortedCol As Long                                       '排序列
Private mlngSortedType As Long                                      '排序方式

Private mblnNoRefresh As Boolean                                    '是否需要格式化数据
Private mblnMouseDownOnFixedRow As Boolean                          'MouseDown时位于固定行区域标志
Private mlngMouseDownCol As Long                                    'MouseDown列
Private mblnCancelRowColChange As Boolean                           '取消Grid行列改变事件
Private mblnColResize As Boolean
Private mlngDragOverCol As Long                                     'DragOver列
Private mblnNotKillText As Boolean

Private WithEvents mEditText As TextBox
Attribute mEditText.VB_VarHelpID = -1
Private WithEvents mCalcEdit As GATLCTRLLibCtl.CalEdit
Attribute mCalcEdit.VB_VarHelpID = -1
Private WithEvents mListText As ListText
Attribute mListText.VB_VarHelpID = -1
Private WithEvents mCalendar As GACALENDARLibCtl.calendar
Attribute mCalendar.VB_VarHelpID = -1
Private EditObject As Control
Private mintEditCol As Integer
Private mstrEditColTitle As String
Private mintRalationCol As Integer
Private mstrRalationColTitle As String
Private mstrRalationValue As String
Private mstrFormat As String
Private blnRefresh As Boolean
Public Event DataValid(blnCancel As Boolean)
Public Event BeforeEdit(blnCancel As Boolean)
Public Event BeforeSave(blnCancel As Boolean)
Public Event BeforeRefresh(lngRow As Long)
Public Event AfterRefresh(lngRow As Long)

Private Sub Class_Initialize()
    '创建对象
    Set mclsSubClassFlex = New SubClass32.SubClass
    Set mclsListSet = New ListSet
    
    ' MSFlexGrid中第0列隐藏，用于存储ID。
    mlngColOfs = 1
End Sub

Private Sub Class_Terminate()
    '撤消对象
    Set mclsSubClassFlex = Nothing
    Set mclsSubClassText = Nothing
    Set mclsListSet = Nothing
    Set mEditText = Nothing
    Set EditObject = Nothing
    Set mFlex = Nothing
    Set mclsHook = Nothing
    Set frmName = Nothing
End Sub


''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
'  属性
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

'Grid属性
Public Property Get Grid() As MSFlexGrid
    Set Grid = mFlex
End Property

Public Property Set Grid(ByVal vNewValue As MSFlexGrid)
    '设置Grid
    Set mFlex = vNewValue
    
    '设置SubClass消息
    With mclsSubClassFlex
        .hwnd = mFlex.hwnd
        .Messages(WM_PAINT) = True
        .Messages(WM_LBUTTONUP) = True
        .Messages(WM_LBUTTONDOWN) = True
        .Messages(WM_MOUSEMOVE) = True
        .Messages(WM_KEYDOWN) = True
    End With
End Property
Public Property Set Form(ByVal vData As Form)
    Dim i As Integer
    Set frmName = vData
    For i = 0 To mFlex.Cols
        If frmName.hLb.UBound < i Then
            Load frmName.hLb(i)
            frmName.hLb(i).Caption = ""
        End If
    Next i
    Set mclsHook = New SubClass32.SubClass
    mclsHook.hwnd = frmName.hwnd
    mclsHook.Messages(WM_PAINT) = True
    blnRefresh = True
End Property
Public Property Get EditText() As Object
    Set EditText = mEditText
End Property

Public Property Set EditText(ByVal vNewValue As Object)
    'Dim prpLoop As Property
    
    If TypeOf vNewValue Is TextBox Then
        Set mEditText = vNewValue
    ElseIf TypeOf vNewValue Is GATLCTRLLibCtl.CalEdit Then
        Set mCalcEdit = vNewValue
    ElseIf TypeOf vNewValue Is ListText Then
        Set mListText = vNewValue
    ElseIf TypeOf vNewValue Is GACALENDARLibCtl.calendar Then
        Set mCalendar = vNewValue
    Else
        Set mEditText = vNewValue
    End If
    
    Set EditObject = vNewValue
    EditObject.Visible = False
    mintEditCol = -1
    mstrFormat = ""
    mintRalationCol = -1
    
    If Not TypeOf vNewValue Is ListText Then
        Set mclsSubClassText = New SubClass32.SubClass
        With mclsSubClassText
            .hwnd = EditObject.hwnd
            .Messages(WM_KILLFOCUS) = True
        End With
    End If
End Property

'是否需要格式化数据
Public Property Get FormatData() As Boolean
    FormatData = Not mblnNoRefresh
End Property

Public Property Let FormatData(ByVal vNewValue As Boolean)
    mblnNoRefresh = Not vNewValue
End Property

'IsSelected属性：返回FlexGrid选中行状态。
Public Property Get IsSelected() As Boolean
    '如果MSFlexGrid当前列和选择列为零，无选中行。
    With mFlex
        IsSelected = Not (.col = 0 And .ColSel = 0) And (.Row >= .FixedRows And .Row < .Rows)
    End With
End Property

'列只读属性
Public Property Get ReadOnlyCol(ByVal lngCol As Long) As Boolean
    ReadOnlyCol = False
    With mFlex
        If lngCol >= .FixedCols And lngCol <= .Cols - 1 And .Rows > 1 Then
            If (.ColData(lngCol) And &HF) = GridReadOnly Then
                ReadOnlyCol = True
            End If
        End If
    End With
End Property

Public Property Let ReadOnlyCol(ByVal lngCol As Long, ByVal blnReadOnly As Boolean)
    Dim lngSaveCol As Long, lngSaveColSel As Long
    Dim lngSaveRow As Long, lngSaveRowSel As Long
    
    With mFlex
        If lngCol >= .FixedCols And lngCol <= .Cols - 1 And .Rows > 1 Then
            If ReadOnlyCol(lngCol) <> blnReadOnly Then
                If blnReadOnly Then
                    .ColData(lngCol) = (.ColData(lngCol) And &HFFF0) + GridReadOnly
                Else
                    .ColData(lngCol) = (.ColData(lngCol) And &HFFF0) + GridReadWrite
                End If
            End If
        End If
    End With
End Property


'列类型：0 字符类型/ 1 数值类型/ 2 日期/3 字符类型（可参照）
Public Property Get ColType(ByVal lngCol As Long) As Integer
    ColType = 0
    With mFlex
        If lngCol >= 1 And lngCol <= .Cols - 1 Then
            ColType = (.ColData(lngCol) And &HF0) \ &H10
        End If
    End With
End Property

Public Property Let ColType(ByVal lngCol As Long, ByVal intType As Integer)
    With mFlex
        If lngCol >= 1 And lngCol <= .Cols - 1 Then
            .ColData(lngCol) = (.ColData(lngCol) And &HF0) + intType * &H10
        End If
    End With
End Property

'可排序列：False 不可排序/ True 可排序
Public Property Get ColSort(ByVal lngCol As Long) As Boolean
    ColSort = False
    With mFlex
        If lngCol >= 1 And lngCol <= .Cols - 1 Then
            If (.ColData(lngCol) And &HF00) \ &H100 = GridOrder Then
                ColSort = True
            End If
        End If
    End With
End Property

Public Property Let ColSort(ByVal lngCol As Long, ByVal blnSort As Boolean)
    With mFlex
        If lngCol >= 1 And lngCol <= .Cols - 1 Then
            If blnSort Then
                .ColData(lngCol) = (.ColData(lngCol) And &HF0FF) + &H100
            Else
                .ColData(lngCol) = (.ColData(lngCol) And &HF0FF)
            End If
        End If
    End With
End Property

'返回排序列
Public Property Get SortedCol() As Long
    SortedCol = mlngSortedCol
End Property

'列排序方式：0 没有排序/ 1 升序/ 2 降序
Public Property Get SortedType() As Integer
    SortedType = mlngSortedType
End Property

'Grid中ListSet列开始位置
Public Property Get ColOfs() As Long
    ColOfs = mlngColOfs
End Property

Public Property Let ColOfs(ByVal vNewValue As Long)
    If vNewValue >= 1 Then
        mlngColOfs = vNewValue
    
        If Not mFlex Is Nothing Then
            If mclsListSet.ViewId = 0 Then
                mFlex.FixedCols = mlngColOfs
            Else
                mFlex.FixedCols = mclsListSet.FixColumns + mlngColOfs
            End If
        End If
    End If
End Property

'返回ListSet对象
Public Property Get ListSet() As ListSet
    Set ListSet = mclsListSet
End Property

'判断指定单元是否可以粘贴控件
Public Property Get CellPaste(ByVal lngRow As Long, ByVal lngCol As Long) As Boolean
    Dim blnIsHScroll As Boolean, blnIsVScroll As Boolean
    Dim lngClientWidth As Long, lngClientHeight As Long
    Dim intOffset As Integer
    
    CellPaste = False
    
    With mFlex
        If lngRow >= .FixedRows And lngRow < .Rows And lngCol >= .FixedCols And lngCol < .Cols And _
            .RowHeight(lngRow) > 0 And .ColWidth(lngCol) > 0 And Not ReadOnlyCol(lngCol) Then
            
            '判断水平滚动条和垂直滚动条
            ISScroll blnIsHScroll, blnIsVScroll
            
            ' 计算Grid内部区域高度、宽度
            intOffset = IIf(.Appearance = flex3D, 4, 0)
            If blnIsVScroll Then
                lngClientWidth = .width - gclsEniv.VScrollWidth - intOffset * Screen.TwipsPerPixelX
            Else
                lngClientWidth = .width - intOffset * Screen.TwipsPerPixelX
            End If
            If blnIsHScroll Then
                lngClientHeight = .Height - gclsEniv.HScrollHeight - intOffset * Screen.TwipsPerPixelY
            Else
                lngClientHeight = .Height - intOffset * Screen.TwipsPerPixelY
            End If
    
            If .RowPos(lngRow) + .RowHeight(lngRow) < lngClientHeight And _
                .ColPos(lngCol) + .ColWidth(lngCol) < lngClientWidth Then
                CellPaste = True
            End If
        End If
    End With
End Property



''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
'  方法
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

'设置GRID风格
Public Sub SetupStyle()
    Dim lngCol, lngCols As Long
    Dim strColType As String
    
    If mFlex Is Nothing Then Exit Sub
     
    '设置MSFlexGrid风格
    With mFlex
        .Redraw = False
        .AllowBigSelection = False
        .AllowUserResizing = flexResizeColumns
        .BorderStyle = flexBorderSingle
        .BackColorBkg = RGB(255, 255, 255)
        .GridColorFixed = RGB(255, 255, 255)
        .BackColorFixed = RGB(255, 255, 255)
        .GridLines = flexGridNone
        .GridLinesFixed = flexGridNone
        .TabStop = True
        If .Rows > 1 Then .FixedRows = 1
        
        Set .DragIcon = GetFormResPicture(101, vbResIcon)
        Set .MouseIcon = GetFormResPicture(101, vbResCursor)
        
        '设置固定行颜色
        mblnCancelRowColChange = True
        .Row = 0
        lngCols = .Cols - 1
        For lngCol = 0 To lngCols
            .col = lngCol
            .CellBackColor = RGB(192, 192, 192)
        Next lngCol
        mblnCancelRowColChange = False

        '设置固定列
        If mclsListSet.ViewId = 0 Then
            .FixedCols = mlngColOfs
        Else
            .FixedCols = mclsListSet.FixColumns + mlngColOfs
        End If
        .ColWidth(0) = 0
        
        '初始化光标
        If .Rows <= 1 Then
            .HighLight = flexHighlightNever
            .Row = 0
        Else
            .HighLight = flexHighlightAlways
            .Row = 1
            If .SelectionMode = flexSelectionByRow Then
                .col = 0
                .ColSel = .Cols - 1
            Else
                If .FixedCols > 1 Then
                    .col = .FixedCols
                    .ColSel = .FixedCols
                Else
                    .col = 1
                    .ColSel = 1
                End If
            End If
        End If
        
        If ListSet.ViewId <> 0 Then
            For lngCol = 1 To ListSet.Columns
                strColType = ListSet.ColumnFieldType(lngCol)
                If strColType = "DOUBLE" Or strColType = "SINGLE" Or _
                    strColType = "LONG" Or strColType = "INTEGER" Then
                    .ColAlignment(lngCol + mlngColOfs - 1) = flexAlignRightCenter