机房收费系统之模块

我在该系统中用到了两个模块：执行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