clsgrid.cls

一个用VB写的财务软件源码

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "clsGrid"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

Enum GridTextFillType
    gftNone = 1
    gftOneRecordSet
End Enum
Enum GridColumnAlignment
    gcaLeft = 1
    gcaCenter
    gcaRight
End Enum

Private m_mFg As MSFlexGrid
Private m_TextFillType As GridTextFillType
Private m_rSt As ADODB.Recordset


Private Sub Class_Initialize()
    m_TextFillType = gftNone
End Sub


'The relation control ( a MsFlexGrid control )
Public Sub Init(ByRef NewGrid As MSFlexGrid)
    Set m_mFg = NewGrid
End Sub

'How to fill the texts in grid
Public Property Let TextFillType(ByVal NewType As GridTextFillType)
    If NewType < gftNone Or NewType > gftOneRecordSet Then
        Err.Raise 380
    Else
        m_TextFillType = NewType
    End If
End Property

'If fill text by one ADODB.RecordSet, then send this parameter
Public Property Let QueryString(ByVal sSQL As String)

    Dim i As Long, iOriginRows As Long, j As Long
    
    If m_TextFillType <> gftOneRecordSet Then
        Err.Raise 380
    Else
        Set m_rSt = New ADODB.Recordset
        With m_rSt
            .CursorLocation = adUseClient
            .Open sSQL, glo.cnnMain, adOpenStatic, adLockReadOnly
            If .RecordCount > 0 Then
                iOriginRows = m_mFg.Rows
                m_mFg.Rows = m_mFg.Rows + .RecordCount
                .MoveFirst
                For i = iOriginRows To m_mFg.Rows - 1
                    For j = 0 To .Fields.Count - 1
                        Select Case .Fields(j).Type
                            Case adDBTimeStamp
                                m_mFg.TextMatrix(i, j) = IIf(IsNull(.Fields(j).Value), "", _
                                        Format(.Fields(j).Value, "yyyy-mm-dd"))
                            Case Else
                                m_mFg.TextMatrix(i, j) = IIf(IsNull(.Fields(j).Value), "", _
                                        .Fields(j).Value)
                        End Select
                    Next j
                    .MoveNext
                Next i
            End If
            .Close
        End With
    End If
    
End Property

'The formatstring of msflexgrid
Public Property Let FormatString(ByVal sHead As String)
    m_mFg.FormatString = sHead
End Property

'The redraw property of msflexgrid
Public Property Let Redraw(ByVal NewRe As Boolean)
    m_mFg.Redraw = NewRe
End Property

'The width of grid
Public Property Let Width(ByVal NewW As Long)
    m_mFg.Width = NewW
End Property
Public Property Get Width() As Long
    Width = m_mFg.Width
End Property

'The height of grid
Public Property Let Height(ByVal NewH As Long)
    m_mFg.Height = NewH
End Property
Public Property Get Height() As Long
    Height = m_mFg.Height
End Property

'The top of grid
Public Property Let Top(ByVal NewT As Long)
    m_mFg.Top = NewT
End Property
Public Property Get Top() As Long
    Top = m_mFg.Top
End Property

'The left of grid
Public Property Let Left(ByVal NewL As Long)
    m_mFg.Left = NewL
End Property
Public Property Get Left() As Long
    Left = m_mFg.Left
End Property

'The active cell of msflexgrid
Public Property Let row(ByVal NewRow As Long)
    m_mFg.row = NewRow
End Property
Public Property Get row() As Long
    row = m_mFg.row
End Property
Public Property Let col(ByVal NewCol As Long)
    m_mFg.col = NewCol
End Property
Public Property Get col() As Long
    col = m_mFg.col
End Property

'The rows of msflexgrid
Public Property Let Rows(ByVal NewRows As Long)
    If NewRows <= 0 Then
        Err.Raise 380
    Else
        m_mFg.Rows = NewRows
    End If
End Property
Public Property Get Rows() As Long
    Rows = m_mFg.Rows
End Property

'The cols of msflexgrid
Public Property Let Cols(ByVal NewCols As Long)
    m_mFg.Cols = NewCols
End Property
Public Property Get Cols() As Long
    Cols = m_mFg.Cols
End Property

'The method to set one celltext
Public Sub SetCellText(ByVal row As Long, ByVal col As Long, Var As Variant)
    m_mFg.TextMatrix(row, col) = IIf(IsNull(Var), "", Var)
End Sub

'The method to get one celltext
Public Function GetCellText(ByVal row As Long, ByVal col As Long) As Variant
    GetCellText = m_mFg.TextMatrix(row, col)
End Function

'The method to get one cell top
Public Function GetCellTop(ByVal row As Long, ByVal col As Long) As Long
    Dim OldRow As Long, oldcol As Long
    With m_mFg
        .Redraw = False
        OldRow = .row
        oldcol = .col
        .row = row
        .col = col
        GetCellTop = .CellTop
        .row = OldRow
        .col = oldcol
        .Redraw = True
    End With
End Function

'The method to get one cell left
Public Function GetCellLeft(ByVal row As Long, ByVal col As Long) As Long
    Dim OldRow As Long, oldcol As Long
    With m_mFg
        .Redraw = False
        OldRow = .row
        oldcol = .col
        .row = row
        .col = col
        GetCellLeft = .CellLeft
        .row = OldRow
        .col = oldcol
        .Redraw = True
    End With
End Function

'The method to get one cell width
Public Function GetCellWidth(ByVal row As Long, ByVal col As Long) As Long
    Dim OldRow As Long, oldcol As Long
    With m_mFg
        .Redraw = False
        OldRow = .row
        oldcol = .col
        .row = row
        .col = col
        GetCellWidth = .cellWidth
        .row = OldRow
        .col = oldcol
        .Redraw = True
    End With
End Function

'The method to get one cell height
Public Function GetCellHeight(ByVal row As Long, ByVal col As Long) As Long
    Dim OldRow As Long, oldcol As Long
    With m_mFg
        .Redraw = False
        OldRow = .row
        oldcol = .col
        .row = row
        .col = col
        GetCellHeight = .cellHeight
        .row = OldRow
        .col = oldcol
        .Redraw = True
    End With
End Function

'The method to set one row height
Public Sub SetRowHeight(ByVal row As Long, HeightInTwip As Long)
    If row < 0 Or row > m_mFg.Rows - 1 Then
        Err.Raise 5
    Else
        m_mFg.RowHeight(row) = HeightInTwip
    End If
End Sub

'The method to set one columne alignment
Public Sub SetColAlignment(ByVal col As Long, ColAlignment As GridColumnAlignment)
    If col < 0 Or col > m_mFg.Cols - 1 Then
        Err.Raise 5
    ElseIf ColAlignment < gcaLeft Or ColAlignment > gcaRight Then
        Err.Raise 5
    Else
        Select Case ColAlignment
            Case 1
                m_mFg.ColAlignment(col) = 1
            Case 2
                m_mFg.ColAlignment(col) = 4
            Case 3
                m_mFg.ColAlignment(col) = 7
        End Select
    End If
End Sub

'The forstolor of one row
Public Sub SetRowForeColor(ByVal iRow As Long, FColor As Long)
    Dim OldRow As Long, oldcol As Long
    Dim j As Long
    
    With m_mFg
        If iRow < 0 Or iRow > .Rows - 1 Then
            Err.Raise 5
        Else
            .Redraw = False
            OldRow = .row
            oldcol = .col
            .row = iRow
            For j = .FixedCols To .Cols - 1
                .col = j
                .CellForeColor = FColor
            Next j
            .row = OldRow
            .col = oldcol
            .Redraw = True
        End If
    End With
        
End Sub

'The backcolor of one row
Public Sub SetRowBackColor(ByVal iRow As Long, BColor As Long)
    Dim OldRow As Long, oldcol As Long
    Dim j As Long
    
    With m_mFg
        If iRow < 0 Or iRow > .Rows - 1 Then
            Err.Raise 5
        Else
            .Redraw = False
            OldRow = .row
            oldcol = .col
            .row = iRow
            For j = .FixedCols To .Cols - 1
                .col = j
                .CellBackColor = BColor
            Next j
            .row = OldRow
            .col = oldcol
            .Redraw = True
        End If
    End With
        
End Sub

'The method to make head text center
Public Sub SetHeadCenter()
    Dim OldRow As Long, oldcol As Long
    Dim j As Long
    
    With m_mFg
        .Redraw = False
        OldRow = .row
        oldcol = .col
        For j = 0 To .Cols - 1
            .row = 0
            .col = j
            .CellAlignment = 4
            .CellFontBold = True
        Next j
        .row = OldRow
        .col = oldcol
        .Redraw = True
    End With
End Sub

'The width string of msflexgrid
Public Property Let WidthString(ByVal sWidth As String)
    
    Dim iTemp As Integer, iCol As Long
    
    iCol = 0
    Do Until Len(sWidth) = 0
        iTemp = InStr(1, sWidth, ",")
        If iTemp = 0 Then
            m_mFg.COLWIDTH(iCol) = Val(sWidth)
            sWidth = ""
        Else
            m_mFg.COLWIDTH(iCol) = Val(Left(sWidth, iTemp - 1))
            sWidth = Mid(sWidth, iTemp + 1)
        End If
        iCol = iCol + 1
        If iCol > m_mFg.Cols Then
            Err.Raise 9
        End If
    Loop
    
End Property

'The alignment string of msflexgrid
Public Property Let AlignmentString(ByVal sAlign As String)
    
    Dim iTemp As Integer, iCol As Long
    
    iCol = 0
    Do Until Len(sAlign) = 0
        iTemp = InStr(1, sAlign, ",")
        If iTemp = 0 Then
            m_mFg.ColAlignment(iCol) = CInt(sAlign)
            sAlign = ""
        Else
            m_mFg.ColAlignment(iCol) = CInt(Left(sAlign, iTemp - 1))
            sAlign = Mid(sAlign, iTemp + 1)
        End If
        iCol = iCol + 1
        If iCol > m_mFg.Cols Then
            Err.Raise 9
        End If
    Loop
    
End Property

'The method for appending one row text
Public Sub AddItem(ParamArray Args() As Variant)
    Dim i As Long
    If UBound(Args) <> m_mFg.Cols Then
        Err.Raise 5
    Else
        m_mFg.Rows = m_mFg.Rows + 1
        For i = 0 To UBound(Args)
            m_mFg.TextMatrix(m_mFg.Rows - 1, i) = Args(i)
        Next i
    End If
End Sub

'The method for previewing the grid
Public Sub PreviewGrid()

    Dim frmP As frmPreview
    
    If Printers.Count = 0 Then
        MsgBox "未安装打印机。", vbInformation
    Else
        m_mFg.Redraw = False
        Set frmP = New frmPreview
        With frmP
            .pControlType = pmsFlexGrid
            .pControl = m_mFg
            .Title = "凭证列表"
            .PaperWidth = Printer.Width
            .PaperHeight = Printer.Height
            .PaperScaleTop = Printer.ScaleTop
            .PaperScaleLeft = 500 ' Printer.ScaleLeft
            .PaperScaleWidth = Printer.ScaleWidth * 0.9
            .PaperScaleHeight = Printer.ScaleHeight * 0.9
            .TitleTop = 200
'            .HeadPlaceType = hgptManual
'            .HeadTop = 800
            .HeadLeft = 700
            .GridLeft = 700
            .ExcutePreview
        End With
        Unload frmP
        m_mFg.Redraw = True
    End If
    
End Sub

'The method for printing the grid
Public Sub PrintGrid()

    Dim frmP As frmPreview
    
    If Printers.Count = 0 Then
        MsgBox "未安装打印机。", vbInformation
    Else
        Set frmP = New frmPreview
        With frmP
            .pControlType = pmsFlexGrid
            .pControl = m_mFg
            .PaperWidth = Printer.Width
            .PaperHeight = Printer.Height
            .PaperScaleTop = Printer.ScaleTop
            .PaperScaleLeft = 500 ' Printer.ScaleLeft
            .PaperScaleWidth = Printer.ScaleWidth * 0.9
            .PaperScaleHeight = Printer.ScaleHeight * 0.9
            .TitleTop = 200
'            .HeadPlaceType = hgptManual
'            .HeadTop = 800
            .HeadLeft = 700
            .GridLeft = 700
            .ExcutePrint
        End With
        Unload frmP
    End If
    
End Sub