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

标签：

日常开发中，经常会针对默写数据表进行增删改查。

每次都要单独处理，费时费力，考虑通过一个窗体进行封装。（借鉴当时接触的某家公司的套路）

外围在调用时，传入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

窗体里，目前只支持标签，文本框，下拉框，通过传入的信息动态加载展示。

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

'关闭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

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

详细代码可见：  http://download.csdn.net/detail/fonjames/9560638

（其实上面已经把大部分代码 贴出来了：-）

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

标签：

原文地址：http://blog.csdn.net/fonjames/article/details/51767502