dbpool.cls

数据库连接封装控件 可以连接Access

    mstrErrDescription = ""
    mlngErrNo = 0
    Set OpenSQLDB = conn
    Exit Function

E:
    mlngErrNo = Err.Number
    mstrErrDescription = Err.Description
    Set conn = Nothing
End Function

'------------------------------------------------------------------------------'
'〖名称〗OpenOralDB()
'〖说明〗打开Oracle数据库
'------------------------------------------------------------------------------'
Private Function OpenOralDB(Provider As String, _
                          User As String, _
                          Pwd As String, _
                          Driver As String) As ADODB.Connection
    ' 打开数据库
    On Error GoTo E
    Dim conn As ADODB.Connection
    Set conn = New ADODB.Connection
    conn.ConnectionString = "Provider=" & Provider & ";User ID=" & User & ";Password=" & Pwd & ";Data Source=" & Driver & ";" & _
                            "Persist Security Info=False;"
    
    conn.Open   ' 不使用异步方式
    
ExitEntry:
    mstrErrDescription = ""
    mlngErrNo = 0
    Set OpenOralDB = conn
    Exit Function

E:
    mlngErrNo = Err.Number
    mstrErrDescription = Err.Description
    Set conn = Nothing
End Function

'******************************************************************************
'目的：     将Recordset存入集合
'输入：
'返回：     数据集合（每条数据亦是一个集合）
'******************************************************************************
Private Function Rst2Collection(ByVal adoRst As ADODB.Recordset) As Collection
    On Error GoTo E
    Dim i As Integer, j As Integer
    Dim varTemp As Collection, varData As Collection
    
    Set varData = New Collection
    If adoRst.EOF Then Exit Function
    adoRst.MoveFirst
    
    Do While Not adoRst.EOF
        Set varTemp = New Collection
        For j = 0 To adoRst.Fields.Count - 1
            varTemp.Add adoRst.Fields(j).Value, adoRst.Fields(j).Name
        Next j
        varData.Add varTemp
        adoRst.MoveNext
    Loop
    Set Rst2Collection = varData
    
ExitEntry:
    On Error Resume Next
    adoRst.Close
    mlngErrNo = 0
    mstrErrDescription = ""
    Exit Function
E:
    mlngErrNo = Err.Number
    mstrErrDescription = Err.Description
End Function

'******************************************************************************
'目的：     保存到数据库(使用不明之处，请参阅类文档)
'输入：     varData-保存的数组(一维代表相应的FIELD，第二维代表记录数目，同ExecuteSQL的返回格式)。
'                 默认varData(0,i)作为每条记录的Key。
'                     varData(0,i)=0 ------Addnew
'                     varData(0,i)=-1------Delete
'                     varData(0,i)>0 ------Update
'                 Important：如果指定了KeyField，则第一维起始一个或几个字段将作为KeyField。
'                    如:指定KeyField为三，则varData(0,i),varData(1,i),varData(2,i)将作为Key.
'
'           varField-保存的字段集合(一维数组)
'                对应varData的所有字段集合,第一维的数目和varData一致，且顺序对应varData。
'           lngKeyCount:关键字字段数目，在Update的时候，按关键字数目进行搜索。
'                缺省默认为1。
'           sTableName-需要更新的表名。
'返回：      执行结果
'******************************************************************************
Public Function Save(ByVal varData As Variant, ByVal varField As Variant, _
                    Optional ByVal lngKeyCount As Long = 1, Optional ByVal sTableName As String = "") As Boolean

    On Error GoTo E
    Dim i As Long, j As Long
    Dim adoRst As New ADODB.Recordset
    
    If Not IsArray(varField) Or Not IsArray(varData) Then Exit Function
    '开始保存
    Dim strValue As String, strSql As String, strSearch As String
    Save = False
    '得到该选取的字段集合
    For i = 0 To UBound(varField)
        strValue = strValue & "," & varField(i)
    Next i
    If Len(Trim(strValue)) > 1 Then
        strValue = Right(strValue, Len(strValue) - 1)
        strSql = "Select " & strValue & " From " & sTableName & " "
    '不可以没有被选取的字段
    Else
        Exit Function
    End If
    '定义关键字段
    
    
    adoRst.CursorLocation = adUseClient
    With adoRst
        '根据varData逐条记录更新表
        For i = 0 To UBound(varData, 2)
            Select Case varData(0, i)
                '表示新增记录
                Case 0
                    .Open strSql & " Where 1=0", mDBConn, adOpenDynamic, adLockOptimistic
                    .AddNew
                    For j = lngKeyCount To adoRst.Fields.Count - 1
                        .Fields(j).Value = varData(j, i)
                    Next j
                    .Update
                    .Close
                '表示删除记录
                Case -1
                    strSearch = ""
                    For j = 0 To lngKeyCount - 1
                       If strSearch = "" Then
                           strSearch = varField(j) & "=" & varData(j, i)
                       Else
                          strSearch = strSearch & " And " & varField(j) & "=" & varData(j, i)
                       End If
                    Next j
                     
                    mDBConn.Execute "Delete From " & sTableName & " Where " & strSearch
                '表示更新记录
                Case Else
                    strSearch = ""
                    For j = 0 To lngKeyCount - 1
                       If strSearch = "" Then
                           strSearch = varField(j) & "=" & varData(j, i)
                       Else
                          strSearch = strSearch & " And " & varField(j) & "=" & varData(j, i)
                       End If
                    Next j
                    
                    .Open strSql & " Where " & strSearch, mDBConn, adOpenDynamic, adLockOptimistic
                                           
                    For j = lngKeyCount To adoRst.Fields.Count - 1
                        .Fields(j).Value = varData(j, i)
                    Next j
                    .Update
                    .Close
            End Select
        Next i
    End With
ExitEntry:
    Save = True
    Exit Function
E:
    mlngErrNo = Err.Number
    mstrErrDescription = Err.Description
End Function

Private Sub Class_Terminate()
    On Error Resume Next
    
    If Not mDBConn Is Nothing Then
        Set mDBConn = Nothing
    End If
    mstrErrDescription = ""
    mlngErrNo = 0
End Sub

Public Sub Clear()
'    mstrField = ""
'    mvarData = ""
    
End Sub
    
Private Sub ReadIniKey()
   On Error Resume Next
   
   mstrDatabase = IniRead(gs_DBPath, conSectionName, conIniDBKey)
   mstrProvider = IniRead(gs_DBPath, conSectionName, conIniProvider)
   mstrPwd = IniRead(gs_DBPath, conSectionName, conIniPwdKey)
   mlngDBType = Val(IniRead(gs_DBPath, conSectionName, conDBTypeKey))
   mstrDriver = IniRead(gs_DBPath, conSectionName, conIniDriverKey)
   
   mstrOpenMode = IniRead(gs_DBPath, conSectionName, conIniOpenMode)
   
   mstrServer = IniRead(gs_DBPath, conSectionName, conIniServerKey)
   mstrUser = IniRead(gs_DBPath, conSectionName, conIniUserKey)
   
End Sub

Public Function ConnectDB(Optional ByVal varPwd) As Boolean
    On Error GoTo E
    Dim sPwd As String
    
    ReadIniKey
    
    If Not IsMissing(sPwd) Then
        sPwd = varPwd
    Else
        sPwd = mstrPwd
    End If
    
    Set mDBConn = New ADODB.Connection
    If mlngDBType = 1 Then
        Set mDBConn = OpenSQLDB(mstrServer, mstrUser, sPwd, mstrDriver, mstrDatabase)
    ElseIf mlngDBType = 2 Then
        Set mDBConn = OpenOralDB(mstrProvider, mstrUser, sPwd, mstrDriver)
    Else
        Set mDBConn = OpenAccessDB(mstrProvider, mstrDatabase, sPwd, mstrOpenMode)
    End If
    If Not mDBConn Is Nothing Then
        mDBConn.CursorLocation = adUseClient
        ConnectDB = True
        Record.DBConnect = mDBConn
    End If
    
ExitEntry:
    mstrErrDescription = ""
    mlngErrNo = 0
    Exit Function
E:
    mlngErrNo = Err.Number
    mstrErrDescription = Err.Description
    Set mDBConn = Nothing
End Function

Public Function CloseDB()
    On Error GoTo ErrH
    
    Record.Init
    If mDBConn.State = adStateOpen Then
       mDBConn.Close
    End If
    If Not mDBConn Is Nothing Then
        Set mDBConn = Nothing
    End If
    
    Exit Function
ErrH:
    
End Function
'------------------------------------------------------------------------------'
'〖名称〗OpenAccessDB()
'〖说明〗打开Access数据库
'------------------------------------------------------------------------------'
Private Function OpenAccessDB(Provider As String, _
                          Database As String, _
                          Password As String, _
                          OpenMode As String, _
                          Optional PersistSecrit As Boolean, _
                          Optional Timeout As Long) As ADODB.Connection
    ' 打开数据库
    On Error GoTo E
    Dim conn As ADODB.Connection, strConn As String
    
    If PersistSecrit Then
        strConn = "Persist Security Info=False;"
    Else
        strConn = "Persist Security Info=True;"
    End If
    strConn = strConn & "Data Source='" & Database & "';"
    strConn = strConn & "Mode=" & OpenMode & ";Jet OLEDB:"
    strConn = strConn & "Database Password=" & Password
    
    Set conn = New ADODB.Connection
    conn.Provider = Provider
    
    If Timeout <> 0 Then conn.ConnectionTimeout = Timeout
    conn.Open strConn   ' 不使用异步方式
    
ExitEntry:
    mstrErrDescription = ""
    mlngErrNo = 0
    Set OpenAccessDB = conn
    Exit Function

E:
    mlngErrNo = Err.Number
    mstrErrDescription = Err.Description
    Set conn = Nothing
End Function