[VB] VB实现一个窗体的增删改查的demo

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

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

'DATABASE层 '封装数据库连接源,及其操作.

'打开到数据源的连接 '##ModelId=384A0336023A Public Sub COpen(Optional ConnectionString As String, Optional szUser As String, Optional szPwd As String, Optional OpenOption As Integer = ⑴) 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

'关闭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 是不是对2进制字段进行操作 '##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 '方法回卷的事务的1部份，或是可以用 CancelBatch 方法取消的批更新的1部份，否则在调用 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 所用的格式。当前默许并唯1有效的值为 adPersistADTG。 ' '在第1次保存 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

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