机房收费系统之模块

我在该系统中用到了两个模块：执行Sql语句和写报表模块。

功能：

执行Sql语句：

该模块主要是可以对Delete， Update，Insert，Select等sql语句进行执行，并连接数据源。

该模块代码：

Public Password As String   '获得登录用户的密码
Public Username As String       '获得登录用户的用户名
Public LeastMoney As Long   '获得基本数据表中的最少金额
'登录成功后进入主窗体
Sub Main()
    Dim fLogin As New frmLogin
    Dim fMain As frmMain
    fLogin.Show vbModal
    If fLogin.bLogin = False Then
        End
    End If
    Unload fLogin
    Set fMain = New frmMain
    fMain.Show
End Sub

'连接字符串
Public Function ConnectString() As String
    ConnectString = "FILEDSN=dan.dsn;UID=sa;PWD=1"
End Function

'执行SQL语句
Public Function ExecuteSQL(ByVal SQL As String, MsgString As String) As ADODB.Recordset
    Dim objCn As ADODB.Connection
    Dim objRs As ADODB.Recordset
    Dim strTokens() As String
    strTokens = Split(SQL)
    Set objCn = New ADODB.Connection
    objCn.Open ConnectString
    On Error GoTo function_error
    If InStr("INSERT,DELETE,UPDATE", UCase(strTokens(0))) Then
        objCn.Execute SQL
        MsgString = strTokens(0) & "successed！“"
    Else
        Set objRs = New ADODB.Recordset
        objRs.CursorLocation = adUseClient
        objRs.Open Trim$(SQL), objCn, adOpenKeyset, adLockOptimistic
        Set ExecuteSQL = objRs
        MsgString = "共查询到：" & objRs.RecordCount & "条记录"
    End If
function_exit:    ’退出
    'objCn.Close
    Set objRs = Nothing
    Set objCn = Nothing
    Exit Function
function_error:     ‘执行错误
    MsgBox "查询错误时：" & Err.Description
    Resume function_exit
End Function

写入报表模块：

该模块中主要自定义了一个函数：

该模块代码：

Private Type MatchFieldPair
     rsField As ADODB.Field
     grField As grproLibCtl.IGRField
End Type

Public Sub GRFetchRecordFromRecordset(Report As GridppReport, rs As ADODB.Recordset)
    If rs.BOF And rs.EOF Then Exit Sub

    Dim grRecordset As grproLibCtl.IGRRecordset
    Set grRecordset = Report.DetailGrid.Recordset

    Dim FieldCount As Integer
    FieldCount = grRecordset.Fields.Count
    Dim rsFieldCount As Integer
    rsFieldCount = rs.Fields.Count
    Dim FieldPairs() As MatchFieldPair
    ReDim FieldPairs(FieldCount)
    Dim MatchFieldCount As Integer
    MatchFieldCount = 0
    Dim i As Integer
    For i = 1 To FieldCount
        Set FieldPairs(MatchFieldCount).grField = grRecordset.Fields.Item(i)
        'Set FieldPairs(MatchFieldCount).rsField = rs.Fields.Item(FieldPairs(MatchFieldCount).grField.Name)
        Dim J As Integer
        For J = 0 To rsFieldCount - 1
            If LCase(FieldPairs(MatchFieldCount).grField.RunningDBField) = LCase(rs.Fields.Item(J).Name) Then
                Set FieldPairs(MatchFieldCount).rsField = rs.Fields.Item(J)
                MatchFieldCount = MatchFieldCount + 1
                Exit For
            End If
        Next
    Next

    rs.MoveFirst
    Do Until rs.EOF
        Report.DetailGrid.Recordset.Append
         For i = 0 To MatchFieldCount - 1
            If Not IsNull(FieldPairs(i).rsField.Value) Then
                Select Case FieldPairs(i).grField.FieldType
                Case grftString
                    FieldPairs(i).grField.AsString = FieldPairs(i).rsField.Value
                Case grftInteger
                    FieldPairs(i).grField.AsInteger = FieldPairs(i).rsField.Value
                Case grftFloat
                    FieldPairs(i).grField.AsFloat = FieldPairs(i).rsField.Value
                Case grftBoolean
                    FieldPairs(i).grField.AsBoolean = FieldPairs(i).rsField.Value
                Case grftDateTime
                    FieldPairs(i).grField.AsDateTime = FieldPairs(i).rsField.Value
                Case Else 'grftBinary
                    FieldPairs(i).grField.Value = FieldPairs(i).rsField.Value
                End Select
            End If
        Next
        Report.DetailGrid.Recordset.Post
        rs.MoveNext
   Loop
End Sub