salarygrid.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 = "SalaryGrid"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

Private mclsListSet As ListSet                          '列表设置对象
Private WithEvents mDbGribCtrl As WINCTRLLib.DBGridCtrl
Attribute mDbGribCtrl.VB_VarHelpID = -1
Private mrecSalary As rdoResultset
Private WithEvents mPicSalary As PictureBox
Attribute mPicSalary.VB_VarHelpID = -1
Private mintFixedRows As Integer   '固定列
Private mintFixedCols As Integer   '固定行
Private mintSortCol As Integer     '排序列
Private mintSortType As Integer    '排序类型 0，不排序, 1，升序，2，降序
Private mstrSortCodeName As String    '排序字段
Private mintStrSalarySql As String '工资SQL

Public Event AfterRowColChange()
Public Event BeforeSaveData(ByRef strVal As String, ByRef lngCancel As Long)
Public Event AfterSaveData(strVal As String)

Private Sub Class_Initialize()
    Set mclsListSet = New ListSet
    Set mDbGribCtrl = New WINCTRLLib.DBGridCtrl
End Sub

Private Sub Class_Terminate()
    Set mclsListSet = Nothing
    Set mDbGribCtrl = Nothing
    If Not mrecSalary Is Nothing Then
        mrecSalary.Close
        Set mrecSalary = Nothing
    End If
End Sub

Public Property Get SalaryDbGridCtrl() As WINCTRLLib.DBGridCtrl
     Set SalaryDbGridCtrl = mDbGribCtrl
End Property

Public Property Get Recordset() As rdoResultset
     Set Recordset = mrecSalary
End Property
Public Property Set Recordset(NewRecordset As rdoResultset)
    If Not NewRecordset.EOF Then NewRecordset.MoveLast
    If Not mrecSalary Is Nothing Then
        mrecSalary.Close
        Set mrecSalary = Nothing
    End If
    Set mrecSalary = NewRecordset
    If Not mrecSalary.EOF Then
        mrecSalary.MoveLast
        mrecSalary.MoveFirst
    End If
End Property

Public Property Get PictureBox() As PictureBox
    Set PictureBox = mPicSalary
End Property

Public Property Set PictureBox(ByVal vNewValue As PictureBox)
     Set mPicSalary = vNewValue
End Property
Public Property Get ListSet() As ListSet
    Set ListSet = mclsListSet
End Property

Public Property Get GridFixedRows() As Integer
    GridFixedRows = mintFixedRows
End Property
Public Property Let GridFixedRows(ByVal intNew As Integer)
    mintFixedRows = intNew
End Property
Public Property Get GridFixedCols() As Integer
    GridFixedCols = mintFixedCols
End Property
Public Property Let GridFixedCols(ByVal intNew As Integer)
    mintFixedCols = intNew
End Property

Public Property Get GridSortCol() As Integer
    GridSortCol = mintSortCol
End Property
Public Property Let GridSortCol(ByVal intNew As Integer)
    mintSortCol = intNew
End Property

Public Property Get GridSortType() As Integer
    GridSortType = mintSortType
End Property
Public Property Let GridSortType(ByVal intNew As Integer)
    mintSortType = intNew
End Property

Public Property Get GridSortCodeName() As String
    GridSortCodeName = mstrSortCodeName
End Property
Public Property Let GridSortCodeName(ByVal strNew As String)
    mstrSortCodeName = strNew
End Property

Public Property Get SalarySql() As String
    SalarySql = mintStrSalarySql
End Property
Public Property Let SalarySql(ByVal strNew As String)
    mintStrSalarySql = strNew
End Property

Public Sub InitGrid()
    mDbGribCtrl.Clear
    mDbGribCtrl.RDORecordset = mrecSalary
    mDbGribCtrl.Cols = mrecSalary.rdoColumns.Count
    mDbGribCtrl.Rows = mrecSalary.RowCount + mintFixedRows
    SetGridFormate
End Sub

Public Sub GetSalaryOpenRec()
    Dim strSql As String
    
    If Trim(mstrSortCodeName) <> "" Then
        strSql = mintStrSalarySql & " Order By " & mstrSortCodeName & " " & IIf(mintSortType = 2, "DESC", "ASC")
    Else
        strSql = mintStrSalarySql
    End If
    If Not mrecSalary Is Nothing Then
        mrecSalary.Close
        Set mrecSalary = Nothing
    End If
    Set mrecSalary = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    If Not mrecSalary.EOF Then
        mrecSalary.MoveLast
        mrecSalary.MoveFirst
    End If
End Sub

'设置DataGrid格式
Public Sub SetGridFormate()
    Dim i As Long
    Dim intCols As Integer
    intCols = mrecSalary.rdoColumns.Count
    With mDbGribCtrl
        .FixedRows = mintFixedRows
        .FixedCols = mintFixedCols
        '设标题'设初始排序列
        For i = 0 To intCols - 1
            If i = mintSortCol Then
                If mintSortType = 1 Then
                    .CellFormula(0, i) = mrecSalary.rdoColumns(i).Name & "↑"
                Else
                    .CellFormula(0, i) = mrecSalary.rdoColumns(i).Name & "↓"
                End If
            Else
                .CellFormula(0, i) = mrecSalary.rdoColumns(i).Name
            End If
        Next
        .SetOption -1, -1, -1, -1, 0, -1, -1, -1
        .ClipCell = 1
        .SetBorder 0, -1, 1 + 2
        .SetColBorder 0, intCols, 1, 0, 2
        .SetColBorder mintFixedCols, mintFixedCols, 2, 0, 16
        .SelectionMode = 1
        .ResizeCol = 1
        .SetOption -1, -1, 0, -1, -1, -1, -1, -1
        '设置固定行颜色
        For i = 0 To intCols - 1
            .SetCellPattern 0, i, 0, i, 0, RGB(192, 192, 192), -1, -1
            .SetCellForeColor 0, 0, 0, intCols, RGB(0, 0, 0)
        Next
        .EnterDirection = 4
        .ColWidth(0) = 0
        .Refresh
        If .Row = 0 Then .Row = 1
        If .Row >= .Rows Then .Row = .Rows - 1
        If intCols > mintFixedCols Then
            .col = mintFixedCols
        End If
    End With
End Sub

Private Sub mDbGribCtrl_AfterCellChange(ByVal Row As Long, ByVal col As Integer)
    RaiseEvent AfterRowColChange
End Sub

Private Sub mDbGribCtrl_AfterChange(ByVal Val As String)
    RaiseEvent AfterSaveData(Val)
End Sub

Private Sub mDbGribCtrl_BeforeChange(Val As String, Cancel As Long)
    RaiseEvent BeforeSaveData(Val, Cancel)
End Sub