日常开发中，经常会针对默写数据表进行增删改查。
每次都要单独处理，费时费力，考虑通过一个窗体进行封装。（借鉴当时接触的某家公司的套路）
外围在调用时，传入sql字符串，展示字符串，然后 被调用窗体根据传入的信息进行排版展示。
同时通过设置 增删改查标志，提供增删改查的关联操作。
Public m_Sql As String
Public m_lbls As String
Public m_View As Integer '0C create 1R retrieve 2 U update D delete
Public m_mcbo As Integer '
Public m_scbo As Integer '
Public m_Conn As CSealConnection
Private sRs As New CSealRecordset
Private m_Count As Integer
Private m_iShow As Integer
Dim flabel() As String
Dim fname() As String
Dim fshow() As Integer
Dim fvalue() As String
Dim fsql() As String
Public m_bFinished As Boolean
'Public m_ModTable As String
Private Sub prepare()
Dim k As Integer
m_Count = 0
m_iShow = 0
If Len(Trim$(m_lbls)) > 0 Then
Dim tmp() As String, fs() As String
sRs.COpen m_Sql, m_Conn, 1, 3, 1
If sRs.RecordCount = 0 And m_View > 0 Then Exit Sub
tmp = Split(m_lbls, ";")
m_Count = UBound(tmp)
ReDim fname(m_Count)
ReDim flabel(m_Count)
ReDim fshow(m_Count)
ReDim fsql(m_Count)
ReDim fvalue(m_Count)
For k = 0 To UBound(tmp)
fs = Split(tmp(k), "#")
flabel(k) = Trim(fs(0))
fname(k) = Trim(fs(1))
fshow(k) = Val(fs(2))
If UBound(fs) > 2 Then fsql(k) = fs(3)
If Val(fs(2)) > 0 Then m_iShow = m_iShow + 1
If m_View > 0 Then fvalue(k) = sRs.GetFieldValue(fname(k))
Next k
m_Count = UBound(fname) + 1
sRs.CClose
End If
End Sub
在传入的 m_lbls里指定 相应的数据库的字段名fname, 需要展示的中文名flabel, 展示的格式fshow, 关联的sql等。
窗体里，目前只支持标签，文本框，下拉框，通过传入的信息动态加载展示。
For k = 0 To m_Count - 1
If k > 0 Then
Load txtFieldValue(k)
Load lblFieldName(k)
Load cboEnum(k)
End If
If fshow(k) = 0 Then
txtFieldValue(k).Visible = False: lblFieldName(k).Visible = False: cboEnum(k).Visible = False
Else
lblFieldName(k).Visible = True: lblFieldName(k).Caption = flabel(k)
lblFieldName(k).Left = lblFieldName(0).Left: lblFieldName(k).Top = txtFieldValue(0).Top + iShow * (txtFieldValue(0).Height + 100)
If fshow(k) = 2 Then '索引其他表
fillCombEnum cboEnum(k), fsql(k), fvalue(k) 'sRs.GetFieldValue(fname(k))
If k = m_scbo Then cboEnum_Click m_mcbo
cboEnum(k).Visible = True: txtFieldValue(k).Visible = False
cboEnum(k).Left = txtFieldValue(0).Left: cboEnum(k).Top = lblFieldName(k).Top
Else ' fshow(k) = 1 Or fshow(k) = 3 Or fshow(k) = 9 Then '文本框
txtFieldValue(k).Text = fvalue(k)
txtFieldValue(k).Visible = True: cboEnum(k).Visible = False
txtFieldValue(k).Left = txtFieldValue(0).Left: txtFieldValue(k).Top = lblFieldName(k).Top
End If
If fshow(k) = 3 Then '时间类型
txtFieldValue(k) = Format(fvalue(k), "yyyy-mm-dd")
End If
If m_View = 1 Or fshow(k) = 9 Then '字段不可改，或虚拟字段
txtFieldValue(k).Enabled = False
cboEnum(k).Locked = True
End If
iShow = iShow + 1
End If
Next k
还有相当一块内容是对数据库(ADO)的封装，在类模块 XXXConnection, XXXXRecordSet, XXXXCommand 实现联接，数据集，命令行等方式的读取更新。
其中connection完成连接的开启，关闭，事务的开启提交，回滚等。
'DATABASE层
'封装数据库连接源,及其操作.'打开到数据源的连接
'##ModelId=384A0336023A
Public Sub COpen(Optional ConnectionString As String, Optional szUser As String, Optional szPwd As String, Optional OpenOption As Integer = -1)
On Error GoTo COpenErr
'your code goes here...
If ConnectionString <> "" Then
m_ConnectString = ConnectionString
End If
TranslateString m_ConnectString
adoConn.Open m_ConnectString, szUser, szPwd, OpenOption
m_State = adoConn.State
iErrNum = 0
szErrmsg = ""
Exit Sub
COpenErr:
iErrNum = Err.Number
szErrmsg = Err.Description
'Call RaiseError(MyUnhandledError, "CSealConnection:COpen Method")
End Sub
'启动新的事务。
'用于返回指示事务嵌套层次的长整型变量.'
'##ModelId=384A06930028
Public Function BeginTrans() As Long
On Error GoTo BeginTransErr
BeginTrans = adoConn.BeginTrans()
'your code goes here...
iErrNum = 0
szErrmsg = ""
Exit Function
BeginTransErr:
iErrNum = Err.Number
szErrmsg = Err.Description
BeginTrans = 0
'Call RaiseError(MyUnhandledError, "CSealConnection:BeginTrans Method")
End Function
'保存所有更改并结束当前事务。它也可以启动新事务
'##ModelId=384A07000078
Public Sub CommitTrans()
On Error GoTo CommitTransErr
'your code goes here...
adoConn.CommitTrans
iErrNum = 0
szErrmsg = ""
Exit Sub
CommitTransErr:
iErrNum = Err.Number
szErrmsg = Err.Description
' Call RaiseError(MyUnhandledError, "CSealConnection:CommitTrans Method")
End Sub
'取消当前事务中所做的任何更改并结束事务。它也可以启动新事务。
'
'##ModelId=384A07390014
Public Sub RollbackTrans()
On Error GoTo RollbackTransErr
'your code goes here...
adoConn.RollbackTrans
iErrNum = 0
szErrmsg = ""
Exit Sub
RollbackTransErr:
iErrNum = Err.Number
szErrmsg = Err.Description
'Call RaiseError(MyUnhandledError, "CSealConnection:RollbackTrans Method")
End Sub
'关闭CSealConnection对象
'##ModelId=384A08EA0032
Public Sub CClose()
On Error GoTo CCloseErr
'your code goes here...
If m_State = adStateOpen Then
adoConn.Close
m_State = adStateClosed
End If
iErrNum = 0
szErrmsg = ""
Exit Sub
CCloseErr:
iErrNum = Err.Number
szErrmsg = Err.Description
'Call RaiseError(MyUnhandledError, "CSealConnection:CClose Method")
End Sub
XXXRecordSet实现对sql的查询（COpen），数据集的遍历，获取，写入等。
'关闭CSealRecordset对象
'##ModelId=384B2E3902F8
Public Sub CClose()
On Error GoTo CCloseErr
'your code goes here...
If adoRecordset.State = adStateOpen Then
adoRecordset.Close
End If
iErrNum = 0
szErrmsg = ""
Exit Sub
CCloseErr:
iErrNum = Err.Number
szErrmsg = Err.Description
'Call RaiseError(Err.Number, "CSealRecordset:CClose Method")
End Sub
'Open 方法可打开代表基本表、查询结果或者以前保存的 Recordset 中记录的游标。
'iBlob 是否对二进制字段进行操作
'##ModelId=384A0ADD014A
Public Sub COpen(source As String, Optional ActiveConnection As CSealConnection, Optional Cursortype As CursorTypeEnum, Optional LockType As LockTypeEnum, Optional Options As Long, Optional iBlob As Integer = 1)
'Dim myconn As New ADODB.Connection
Dim dbMode As String
On Error GoTo COpenErr
'your code goes here...
If adoRecordset.State = adStateOpen Then
adoRecordset.Close
End If
source = UCase(source)
If ActiveConnection Is Nothing Then
adoRecordset.Open source, , Cursortype, LockType, Options
Else
dbMode = ActiveConnection.m_DbMode
Select Case dbMode
Case "SQLSERVER", "SQLOLEDB", "MYSQL"
adoRecordset.CursorLocation = adUseClient
Case "DB2":
If iBlob = 0 Then '/*没有BLOB字段操作
adoRecordset.CursorLocation = adUseServer
Else
adoRecordset.CursorLocation = adUseClient
End If
End Select
'adoRecordset.Open source, ActiveConnection.CurConnection, Cursortype, LockType, Options
adoRecordset.Open source, ActiveConnection.MyConnection, Cursortype, LockType, Options
'adoRecordset.Open Source, myconn, Cursortype, LockType, Options
End If
iErrNum = 0
szErrmsg = ""
Exit Sub
COpenErr:
iErrNum = Err.Number
szErrmsg = Err.Description
'Call RaiseError(Err.Number, "CSealRecordset:COpen Method")
End Sub
'为可更新的 Recordset 对象创建新记录。
'
'
'##ModelId=384A0C6E03AC
Public Sub AddNew()
On Error GoTo AddNewErr
'your code goes here...
adoRecordset.AddNew
iErrNum = 0
szErrmsg = ""
Exit Sub
AddNewErr:
iErrNum = Err.Number
szErrmsg = Err.Description
''Call RaiseError(MyUnhandledError, "CSealRecordset:AddNew Method")
End Sub
'使用 CancelUpdate 方法可取消对当前记录所作的任何更改或放弃新添加的记录。除非所做的更改是可以用 RollbackTrans
'方法回卷的事务的一部分，或者是可以用 CancelBatch 方法取消的批更新的一部分，否则在调用 Update 方法后将无法撤消对当前记录或新记录所做的更-
'-
'改，
'
'如果在调用 CancelUpdate 方法时添加新记录，则调用 AddNew 之前的当前记录将再次成为当前记录。
'
'如果尚未更改当前记录或添加新记录，调用 CancelUpdate 方法将产生错误。
'
'##ModelId=384A0CD4033E
Public Sub CancelUpdate()
On Error GoTo CancelUpdateErr
'your code goes here...
adoRecordset.CancelUpdate
iErrNum = 0
szErrmsg = ""
Exit Sub
CancelUpdateErr:
iErrNum = Err.Number
szErrmsg = Err.Description
'Call RaiseError(Err.Number, "CSealRecordset:CancelUpdate Method")
End Sub
'使用 Delete 方法可标记 Recordset 对象中的当前记录。如果 Recordset 对象不允许删除记录将引发错误。使用立即更新模式将在数据库中进行-
'-
'立即删除，否则记录将标记为从缓存删除，实际的删除将在调用 UpdateBatch 方法时进行
'##ModelId=384A0DAD01FE
Public Sub Delete(Optional iAffectRecords As AffectEnum = adAffectCurrent)
On Error GoTo DeleteErr
'your code goes here...
adoRecordset.Delete iAffectRecords
iErrNum = 0
szErrmsg = ""
Exit Sub
DeleteErr:
iErrNum = Err.Number
szErrmsg = Err.Description
'Call RaiseError(Err.Number, "CSealRecordset:Delete Method")
End Sub'将 Recordset 保存（持久）在文件中。
'在 Save 方法完成后，当前行位置将成为 Recordset 的首行。
'
'FileName 可选。保存 Recordset 的文件的完整路径名。
'
'PersistFormat 可选。保存 Recordset 所用的格式。当前默认并唯一有效的值为 adPersistADTG。
'
'在第一次保存 Recordset 时指定 FileName。如果随后调用 Save，应忽略 FileName，否则将产生运行时错误。如果随后用新的
'FileName 调用 Save，那么 Recordset 将保存到新文件中，不过新文件和原始文件都是打开的。
'
'Save 不关闭 Recordset 或 FileName，从而可以继续使用 Recordset 并保存最新的更改。在 Recordset 关闭之前
'FileName 将保持打开，在这段时间其他应用程序可以读取但不能写入 FileName。
'
'
'##ModelId=384A117E01A4
Public Sub Save(ByVal filename As String, Optional PersistFormat As Integer)
On Error GoTo SaveErr
'your code goes here...
If Dir(filename) <> "" Then
Kill filename
End If
adoRecordset.Save filename, PersistFormat
iErrNum = 0
szErrmsg = ""
Exit Sub
SaveErr:
iErrNum = Err.Number
szErrmsg = Err.Description
''Call RaiseError(Err.Number, "CSealRecordset:Save Method")
End Sub
Public Sub Edit()
End Sub
'保存对 Recordset 对象的当前记录所做的所有更改
'使用 Update 方法保存自从调用 AddNew 方法，或自从现有记录的任何字段值发生更改之后，对 Recordset 对象的当前记录所作的所有更改。Re-
'cordset
'对象必须支持更新。
'
'
'##ModelId=384A12350096
Public Sub Update()
On Error GoTo UpdateErr
'your code goes here...
'/*还要添加校验字段的计算 By Anthony
adoRecordset.Update
iErrNum = 0
szErrmsg = ""
Exit Sub
UpdateErr:
iErrNum = Err.Number
szErrmsg = Err.Description
''Call RaiseError(MyUnhandledError, "CSealRecordset:Update Method")
End Sub
'##ModelId=3855AA160334
Public Sub SetFieldValue(ByVal szFdname As String, FdValue As Variant)
adoRecordset.Fields(szFdname) = FdValue
End Sub
'##ModelId=3855AA170280
Public Function GetFieldValue(ByVal szFdname As String) As String
On Error GoTo errorhandle
GetFieldValue = Trim("" & adoRecordset.Fields(szFdname))
iErrNum = 0
szErrmsg = ""
Exit Function
errorhandle:
iErrNum = Err.Number
szErrmsg = Err.Description
GetFieldValue = ""
End Function
Public Function GetFieldValueByIndex(ByVal Index As Long) As String
GetFieldValueByIndex = Trim("" & adoRecordset.Fields(Index).value)
End Function
'得到Field的名字
'##ModelId=3855AA18008C
Public Function GetFieldName(FieldNum As Integer) As String
On Error GoTo GetFieldNameErr
'your code goes here...
GetFieldName = adoRecordset.Fields(FieldNum).Name
iErrNum = 0
szErrmsg = ""
Exit Function
GetFieldNameErr:
iErrNum = Err.Number
szErrmsg = Err.Description
'Call RaiseError(Err.Number, "CSealRecordset:GetFieldName Method")
End Function
'返回Field的类型.
'##ModelId=3855AA1802B2
Public Function GetFieldType(FieldNum As Integer) As DataTypeEnum
On Error GoTo GetFieldTypeErr
'your code goes here...
GetFieldType = adoRecordset.Fields(FieldNum).Type
iErrNum = 0
szErrmsg = ""
Exit Function
GetFieldTypeErr:
iErrNum = Err.Number
szErrmsg = Err.Description
'Call RaiseError(Err.Number, "CSealRecordset:GetFieldType Method")
End Function
而command类模块，实现一些批处理命令的封装。
Public Function ExecuteCmd(Optional lRowsAffected As Long, Optional ByRef vParameters As Variant, Optional lOptions As CommandTypeEnum) As CSealRecordset
On Error GoTo errorhandle
Set ExecuteCmd = New CSealRecordset
Set ExecuteCmd.CurRecordset = adoCommand.Execute(lRowsAffected, vParameters, lOptions)
iErrNum = 0
szErrmsg = ""
Exit Function
errorhandle:
iErrNum = Err.Number
szErrmsg = Err.Description
End Function
例子
' Set sqlCmd.ActiveConnection = m_Conn
' sqlCmd.CommandType = 1
' sqlCmd.CommandText = "delete from tbl_module_pv where tdate='" & txtSelDate & "' and moduleid=" & rs.GetFieldValue("moduleid") _
' & ";insert into tbl_module_pv(moduleid,tdate,profit,tlist) " _
' & " (select t.moduleid, tv.tdate, sum(tv.profit),group_concat(tv.taskid) from tbl_task_pv tv, tbl_task t" _
' & " where t.taskid=tv.taskid and tdate='" & txtSelDate & "' group by moduleid having moduleid = " & rs.GetFieldValue("moduleid") & " )"
' sqlCmd.ExecuteCmd
本文章为转载内容，我们尊重原作者对文章享有的著作权。如有内容错误或侵权问题，欢迎原作者联系我们进行内容更正或删除文章。
