PcAdodb
'保持属性值的局部变量
Private m_Qcn As ADODB.Connection
Private m_Scn As ADODB.Connection
Private m_RS As ADODB.Recordset
Private m_Cmd As ADODB.Command
'要引发该事件，请遵循下列语法使用 RaiseEvent:
'RaiseEvent ErrCN[(arg1, arg2, ... , argn)]
Public Event errcn(ByVal ErrNo As Long, ByVal Desc As String)
Public Property Get RS() As ADODB.Recordset
'检索属性值时使用，位于赋值语句的右边。
'Syntax: Debug.Print X.RS
Set RS = m_RS
End Property
Public Property Get Scn() As ADODB.Connection
'检索属性值时使用，位于赋值语句的右边。
'Syntax: Mycn= CADODB_Sql.qcn
Set Scn = m_Scn
End Property
'Public Property Get qcn() As ADODB.Connection
'检索属性值时使用，位于赋值语句的右边。
'Syntax: Mycn= CADODB_Sql.qcn
' Set qcn = m_qcn
'End Property
Public Function CreateCN(ServerName As String, DataBase As String) As Boolean
Dim I As Long, rtn As Boolean
If m_Qcn.State = adStateOpen Then
m_Qcn.Close
End If
If m_Scn.State = adStateOpen Then
m_Scn.Close
End If
rtn = False
On Error GoTo err_qcn:
I = 0
m_Qcn.CommandTimeout = 25
m_Qcn.Provider = "sqloledb"
m_Qcn.Properties("Data Source").Value = ServerName
m_Qcn.Properties("Initial Catalog").Value = DataBase
m_Qcn.Properties("Persist Security Info").Value = False
m_Qcn.Properties("User ID").Value = "sa"
m_Qcn.Properties("Password").Value = SysPassword
m_Qcn.CursorLocation = adUseServer
m_Qcn.Open
I = 1
m_Scn.CommandTimeout = 25
m_Scn.Provider = "sqloledb"
m_Scn.Properties("Data Source").Value = ServerName
m_Scn.Properties("Initial Catalog").Value = DataBase
m_Scn.Properties("Persist Security Info").Value = False
m_Scn.Properties("User ID").Value = "sa"
m_Scn.Properties("Password").Value = SysPassword
m_Scn.CursorLocation = adUseServer
m_Scn.Open
rtn = True
CreateCN = rtn
Exit Function
err_qcn:
Dim err_No As Long
Dim script As String
Dim errobj As ADODB.Error
CreateCN = rtn
If I = 0 Then
err_No = m_Qcn.Errors.Count
Set errobj = m_Qcn.Errors.Item(err_No - 1)
Else
err_No = m_Scn.Errors.Count
Set errobj = m_Scn.Errors.Item(err_No - 1)
End If
script = errobj.Description
RaiseEvent errcn(err_No, script)
End Function
Public Sub CloseCN()
If m_Qcn.State = adStateOpen Then
m_Qcn.Close
End If
If m_Scn.State = adStateOpen Then
m_Scn.Close
End If
End Sub
Public Function DelRec(ByVal sqlstr As String) As Boolean
Dim rtn As Boolean
rtn = True
On Error GoTo err_del:
m_Cmd.CommandText = sqlstr
m_Cmd.CommandType = adCmdText
Set m_Cmd.ActiveConnection = m_Scn
m_Cmd.Execute
DelRec = rtn
Exit Function
err_del:
rtn = False
DelRec = rtn
End Function
'RecVal 语法: 字段名（号），值
Public Function NewRec(ByVal TableName As String, ByVal RecVal As Collection) As Boolean
Dim I As Long, datatable As String
Dim myrs As ADODB.Recordset
datatable = TableName
On Error GoTo err_new:
Set myrs = New ADODB.Recordset
myrs.Open datatable, m_Scn, adOpenStatic, adLockOptimistic
myrs.AddNew
For I = 1 To RecVal.Count \ 2
myrs(RecVal.Item(2 * I - 1)) = RecVal.Item(2 * I)
Next I
myrs.UpDate
myrs.Close
Set myrs = Nothing
NewRec = True
Exit Function
err_new:
NewRec = False
End Function
'RecVal 语法: 字段名（号），值
Public Function EditRec(ByVal sqlstr As String, ByVal RecVal As Collection) As Boolean
Dim I As Long, datastr As String
Dim myrs As ADODB.Recordset
datastr = sqlstr
On Error GoTo err_edit:
Set myrs = New ADODB.Recordset
myrs.Open datastr, m_Scn, adOpenStatic, adLockOptimistic
For I = 1 To RecVal.Count \ 2
myrs(RecVal.Item(2 * I - 1)) = RecVal.Item(2 * I)
Next I
myrs.UpDate
myrs.Close
Set myrs = Nothing
EditRec = True
Exit Function
err_edit:
EditRec = False
End Function
Public Sub RSTableQueryF(ByVal TableName As String)
Dim mystr As String
mystr = TableName
On Error GoTo err_RST:
If m_RS.State <> 0 Then
m_RS.Close
End If
m_RS.CursorType = adOpenForwardOnly
m_RS.LockType = adLockReadOnly
m_RS.Open mystr, m_Qcn, , , adCmdTable
Exit Sub
err_RST:
Dim err_No As Long
Dim script As String
Dim errobj As ADODB.Error
err_No = m_Qcn.Errors.Count
Set errobj = m_Qcn.Errors.Item(err_No - 1)
script = errobj.Description
RaiseEvent errcn(err_No, script)
End Sub
Public Function RSQuery(ByVal sqlstr As String) As Boolean
Dim mystr As String
mystr = sqlstr
On Error GoTo err_RSQ:
If m_RS.State <> 0 Then
m_RS.Close
End If
m_RS.CursorType = adOpenKeyset
m_RS.LockType = adLockReadOnly
m_RS.Open mystr, m_Qcn, , , adCmdText
RSQuery = True
Exit Function
err_RSQ:
RSQuery = False
End Function
Public Sub RSQueryF(ByVal sqlstr As String)
Dim mystr As String
mystr = sqlstr
On Error GoTo err_RSQF:
If m_RS.State <> 0 Then
m_RS.Close
End If
m_RS.CursorType = adOpenForwardOnly
m_RS.LockType = adLockReadOnly
m_RS.Open mystr, m_Qcn, , , adCmdText
Exit Sub
err_RSQF:
Dim err_No As Long
Dim script As String
Dim errobj As ADODB.Error
err_No = m_Qcn.Errors.Count
Set errobj = m_Qcn.Errors.Item(err_No - 1)
script = errobj.Description
RaiseEvent errcn(err_No, script)
End Sub
Public Function OpenRSTable(ByVal TableName As String) As Boolean
Dim rtn As Boolean
On Error GoTo err_ORST:
If m_RS.State <> 0 Then
m_RS.Close
End If
m_RS.CursorType = adOpenKeyset
m_RS.LockType = adLockBatchOptimistic
m_RS.Open TableName, m_Scn, , , adCmdTable
OpenRSTable = True
Exit Function
err_ORST:
OpenRSTable = False
End Function
Public Function OpenRS(ByVal sqlstr As String) As Boolean
Dim mystr As String
mystr = sqlstr
On Error GoTo err_ORS:
If m_RS.State <> 0 Then
m_RS.Close
End If
m_RS.CursorType = adOpenKeyset
m_RS.LockType = adLockBatchOptimistic
m_RS.Open mystr, m_Scn, , , adCmdText
OpenRS = True
Exit Function
err_ORS:
OpenRS = False
End Function
Public Function UpdateRS(Optional ByVal pCancel As Boolean = False) As Boolean
On Error GoTo err_update:
If pCancel Then
m_RS.CancelBatch
Else
m_RS.UpdateBatch
End If
m_RS.Close
UpdateRS = True
Exit Function
err_update:
UpdateRS = False
End Function
Public Function Truncate(ByVal TabName As String) As Boolean
On Error GoTo err_Truncate:
m_Cmd.CommandText = "TRUNCATE TABLE " & TabName
m_Cmd.CommandType = adCmdText
Set m_Cmd.ActiveConnection = m_Scn
m_Cmd.Execute
Truncate = True
Exit Function
err_Truncate:
Truncate = False
End Function
Private Sub Class_Initialize()
Set m_Qcn = New ADODB.Connection
Set m_Scn = New ADODB.Connection
Set m_RS = New ADODB.Recordset
Set m_Cmd = New ADODB.Command
End Sub
Private Sub Class_Terminate()
Set m_Qcn = Nothing
Set m_Scn = Nothing
If m_RS.State <> 0 Then
m_RS.Close
End If
Set m_RS = Nothing
Set m_Cmd = Nothing
End Sub
