dbpool.cls

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

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "DBPool"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Option Explicit
Private Const conIniPath As String = "DBConfig.Ini"
Private Const conIniDBKey As String = "Database"
Private Const conIniPwdKey As String = "Pwd"
Private Const conIniProvider As String = "Provider"
Private Const conDBTypeKey   As String = "DBType"

'Use For OpenSQL
Private Const conIniUserKey As String = "User"
Private Const conIniServerKey As String = "Server"
Private Const conIniDriverKey As String = "Driver"
Private Const conSectionName  As String = "ActiveDBConfig"

'Use For Open Access DB
Private Const conIniOpenMode As String = "OpenMode"

Public Record As CRecord

Public Enum ReturnType
   ReturnBoolean = 0
   ReturnCollection = 1
   ReturnArray = 2
End Enum

Private mlngDBType As Long

Private mstrPwd     As String
Private mstrDatabase As String
Private mstrProvider As String
'Use For Access
Private mstrOpenMode As String

'Use For SQL SERVER
Private mstrDriver As String
Private mstrUser    As String
Private mstrServer As String

Private mlngErrNo  As Long
Private mstrErrDescription As String

Private mDBConn As ADODB.Connection
Private mbIsTransBegin As Boolean

'******************************************************************************
'目的：     取得当前错误号
'输入：
'返回：     错误号
'******************************************************************************
Public Property Get ErrNo() As Long
    ErrNo = mlngErrNo
End Property

'******************************************************************************
'目的：     取得当前错误描述
'输入：
'返回：     错误描述
'******************************************************************************
Public Property Get ErrDescription() As String
        ErrDescription = mstrErrDescription
End Property

'******************************************************************************
'目的：     取得当前数据库的路径
'输入：
'返回：     数据库的路径
'******************************************************************************
Public Property Get DBPath() As String
    DBPath = gs_DBPath
End Property

'******************************************************************************
'目的：     设置当前数据库的路径
'输入：     数据库的路径
'返回：
'******************************************************************************
Public Property Let DBPath(sPath As String)
    gs_DBPath = sPath
End Property

'******************************************************************************
'目的：     对象初始化
'输入：
'返回：
'******************************************************************************
Private Sub Class_Initialize()
    On Error Resume Next
    
    If gs_DBPath = "" Then
        If Right(App.Path, 1) = "\" Then
            gs_DBPath = App.Path & conIniPath
        Else
            gs_DBPath = App.Path & "\" & conIniPath
        End If
    End If
    Set Record = New CRecord
End Sub


'******************************************************************************
'目的：     开始一个事务
'输入：
'返回：     True-成功，False-失败；失败原因可查阅错误属性
'******************************************************************************

Public Function BeginTrans() As Boolean
    On Error GoTo E
    BeginTrans = False
    If mbIsTransBegin = True Then
        mstrErrDescription = "事务已经开始，请终止后再开始新的事务!"
        mlngErrNo = -1
    End If
    
    mDBConn.BeginTrans
    mbIsTransBegin = True
    BeginTrans = True
ExitEntry:
    mstrErrDescription = ""
    mlngErrNo = 0
    Exit Function
E:
    BeginTrans = False
    mlngErrNo = Err.Number
    mstrErrDescription = Err.Description
End Function


'******************************************************************************
'目的：     事务提交
'输入：
'返回：     True-成功，False-失败；失败原因可查阅错误属性
'******************************************************************************

Public Function CommitTrans() As Boolean
    On Error GoTo E
    CommitTrans = False
    
    If Not mbIsTransBegin Then
        mstrErrDescription = "当前没有任何活动的事务，无法提交事务!"
        mlngErrNo = -1
        Exit Function
    End If
    mDBConn.CommitTrans
    CommitTrans = True
    mbIsTransBegin = False
ExitEntry:
    mstrErrDescription = ""
    mlngErrNo = 0
    Exit Function
E:
    CommitTrans = False
    mlngErrNo = Err.Number
    mstrErrDescription = Err.Description
End Function

'******************************************************************************
'目的：     事务回滚
'输入：
'返回：     True-成功，False-失败；失败原因可查阅错误属性
'******************************************************************************

Public Function RollbackTrans() As Boolean
    On Error GoTo E
    RollbackTrans = False
    
    If Not mbIsTransBegin Then
        mstrErrDescription = "当前没有任何活动的事务，无法回滚事务!"
        mlngErrNo = -1
        Exit Function
    End If
    
    mDBConn.RollbackTrans
    RollbackTrans = True
    mbIsTransBegin = False
ExitEntry:
    mstrErrDescription = ""
    mlngErrNo = 0
    Exit Function
E:
    RollbackTrans = False
    mlngErrNo = Err.Number
    mstrErrDescription = Err.Description
End Function

'******************************************************************************
'目的：     得到Recordset
'输入：     strSQL-SQL语句
'返回：      结果Recordset
'******************************************************************************

Public Function GetRecordSet(ByVal strSql As String) As Recordset
    On Error GoTo E
    Dim adoRst As New ADODB.Recordset
    
    adoRst.Open strSql, mDBConn, adOpenForwardOnly
    Set GetRecordSet = adoRst

ExitEntry:
    mstrErrDescription = ""
    mlngErrNo = 0
    Exit Function
E:
    mlngErrNo = Err.Number
    mstrErrDescription = Err.Description
End Function

'******************************************************************************
'目的：     执行SQL语句
'输入：     strSQL-SQL语句
'返回：      执行结果
'******************************************************************************

Public Function ExecuteSQL(ByVal strSql As String, Optional iRecordsAffected As Integer) As Boolean
    On Error GoTo E
    mDBConn.Execute strSql, iRecordsAffected
ExitEntry:
    ExecuteSQL = True
    mstrErrDescription = ""
    mlngErrNo = 0
    Exit Function
E:
    ExecuteSQL = False
    mlngErrNo = Err.Number
    mstrErrDescription = Err.Description
End Function

'******************************************************************************
'目的：     执行SQL语句
'输入：     strSQL-SQL语句
'返回：     查询产生的结果集存放于集合中返回。
'******************************************************************************

Public Function OpenQuerry(ByVal strSql As String) As Collection
    On Error GoTo E
    Dim Result As Collection
    Dim adoRst As New ADODB.Recordset
    
    Set Result = New Collection
    adoRst.Open strSql, mDBConn, adOpenForwardOnly
    If Not adoRst.EOF Then
        Set Result = Rst2Collection(adoRst)
    End If
    Set OpenQuerry = Result

ExitEntry:
    mstrErrDescription = ""
    mlngErrNo = 0
    Exit Function
E:
    mlngErrNo = Err.Number
    mstrErrDescription = Err.Description
End Function



'------------------------------------------------------------------------------'
'〖名称〗OpenSQLDB()
'〖说明〗打开SQL数据库
'------------------------------------------------------------------------------'
Private Function OpenSQLDB(Server As String, _
                          User As String, _
                          Pwd As String, _
                          Driver As String, _
                          Database As String, _
                          Optional Timeout As Long, _
                          Optional Provider As String = "MSDASQL", _
                          Optional AutoTranslate As Boolean) As ADODB.Connection
    ' 打开数据库
    On Error GoTo E
    Dim conn As ADODB.Connection
    Set conn = New ADODB.Connection
    conn.Provider = Provider
If AutoTranslate = 1 Then
    conn.ConnectionString = "driver=" & Driver & ";server=" & Server & ";uid=" & User & _
                            ";pwd=" & Pwd & ";database=" & Database & ";"
                                 
Else
    conn.ConnectionString = "driver=" & Driver & ";server=" & Server & ";uid=" & User & ";AutoTranslate=No" & _
                            ";pwd=" & Pwd & ";database=" & Database & ";"
End If
    
    If Timeout <> 0 Then conn.ConnectionTimeout = Timeout
    conn.Open   ' 不使用异步方式
    
ExitEntry: