Vb对OO4O的封装

Vb访问Oracle 的数据库，Oracle 本身提供了一组对象Oracle Objects for OLE
这里简称 OO4O ,为了方便，我将他们重新封装成COo4o,全部源代码如下，希望大家调试纠错，注释我就免了，也想看看可读性怎么样大家可以随便使用，但是有改进的地方不要忘记通知我，谢谢
参照:http://cs.cegep-heritage.qc.ca/oracledocs/win.901/a90173/o4o00000.htm

Public Enum OraParamType
  ORAPARM_INPUT = 1
  ORAPARM_OUTPUT = 2
  ORAPARM_BOTH = 3
End Enum

Public Enum OraServerType
  ORATYPE_VARCHAR2 = 1
  ORATYPE_NUMBER = 2
  ORATYPE_VARCHAR = 9
  ORATYPE_DATE = 12
  ORATYPE_CHAR = 96
  ORATYPE_OBJECT = 108
  ORATYPE_BLOB = 113
  ORATYPE_VARRAY = 247
End Enum

Private m_objOraDatabase As Object
Private m_objOraSession As Object
Private m_blnShowMsg As Boolean
Private m_lngDbErrId As Long
Private m_strDbErrMsg As String
Private m_arrParams() As String
Private m_intParams As Integer

Const clngNormal  As Long = 1
Const clngError As Long = 0
Const clngErrTransBegin As Long = -1
Const clngErrTrans As Long = -2
Const clngErrTransRollBack As Long = -3
Const clngErrNullSession As Long = -100
Const ErrNullDB = -200

Public Property Get Database() As Variant
  Set Database = m_objOraDatabase
End Property

Public Property Get Session() As Variant
  Set Session = m_objOraSession
End Property

Public Static Property Get DbErrId() As Long
  DbErrId = m_lngDbErrId
End Property

Public Static Property Get DbErrMsg() As String
  DbErrMsg = m_strDbErrMsg
End Property

Public Static Property Get NullSession() As Long
  NullSession = clngErrNullSession
End Property

Public Static Property Get NullDatabase() As Long
  NullDatabase = ErrNullDB
End Property

Public Static Property Get RetNormal() As Long
  RetNormal = clngNormal
End Property

Public Static Property Get RetError() As Long
  RetError = clngError
End Property

Public Static Property Get RetErrTransBegin() As Long
  RetErrTransBegin = clngErrTransBegin
End Property

Public Static Property Get RetErrTransRollBack() As Long
  RetErrTransRollBack = clngErrTransRollBack
End Property

Public Static Property Get RetErrTrans() As Long
  RetErrTrans = clngErrTrans
End Property

Private Sub Class_Initialize()
  m_intParams = 0
  ReDim m_arrParams(0)
  
  m_blnShowMsg = True
End Sub

Private Sub Class_Terminate()
  Call CloseDB
End Sub

Public Function ConnectDatabase(ByVal pvstrUser As String, ByVal pvstrPass As String, ByVal pvstrDB As String) As Boolean
  On Error GoTo SkipErrCase

  Set m_objOraSession = CreateObject("OracleInProcServer.XOraSession")
  Set m_objOraDatabase = m_objOraSession.DbOpenDatabase(pvstrDB,  pvstrUser & "/" & pvstrPass, 0&)
  m_lngDbErrId = clngNormal
  Exit Function
SkipErrCase:
  Dim lngRet As Long
  lngRet = doDbError
  
  If Err <> 0 Then 'Err.Description
    ConnectDatabase = False
    Call CloseDB
  Else
    ConnectDatabase = True
  End If
End Function

Public Function BeginTrans() As Long
  On Error GoTo SkipErrCase
  m_objOraSession.BeginTrans
  m_lngDbErrId = clngNormal
  BeginTrans = clngNormal
  Exit Function
SkipErrCase:
  'BeginTrans = doDbError
  m_lngDbErrId = clngErrTransBegin
  BeginTrans = clngErrTransBegin
End Function

Public Function RollBack() As Long
  On Error GoTo SkipErrCase
  m_objOraSession.RollBack
  m_lngDbErrId = clngNormal
  RollBack = clngNormal
  Exit Function
SkipErrCase:
  'RollBack = doDbError
  m_lngDbErrId = clngErrTransRollBack
  RollBack = clngErrTransRollBack
End Function

Public Function CommitTrans() As Long
  On Error GoTo SkipErrCase
  m_objOraSession.CommitTrans
  m_lngDbErrId = clngNormal
  CommitTrans = clngNormal
  Exit Function
SkipErrCase:
  'CommitTrans = doDbError
  m_lngDbErrId = clngErrTrans
  CommitTrans = clngErrTrans
End Function

Public Function Execute(ByVal strSQL As String) As Long
  On Error GoTo SkipErrCase

  Execute = m_objOraDatabase.ExecuteSQL(strSQL)
  m_lngDbErrId = clngNormal
  Execute = clngNormal
  Exit Function
SkipErrCase:
  Execute = doDbError
End Function

Public Function OpenRecordset(ByVal strSQL As String,  Optional ByVal varOption As OraDynType = CLng(0)) As Object
  
  On Error GoTo SkipErrCase

  Set OpenRecordset = m_objOraDatabase.DbCreateDynaset(strSQL, varOption)
  m_lngDbErrId = clngNormal
  Exit Function
SkipErrCase:
  Call doDbError
  Set OpenRecordset = Nothing
End Function

Public Sub CloseDB()
  If Not m_objOraDatabase Is Nothing Then
    m_objOraDatabase.Close
    Set m_objOraDatabase = Nothing
  End If
  
  If Not m_objOraSession Is Nothing Then
    Set m_objOraSession = Nothing
  End If
End Sub

Public Function ParamsRemove(ByVal Name As String) As Boolean
  Dim blnRet As Boolean
  blnRet = removeParamsArray(Name)
  If blnRet = True Then
    Call m_objOraDatabase.Parameters.Remove(Name)
  End If
  ParamsRemove = blnRet
End Function

Public Function ParamsAdd(ByVal Name As String, ByVal Value As Variant, ByVal ServerType As OraServerType, ByVal Derection As OraParamType) As Boolean
  Dim blnRet As Boolean
  blnRet = addParamsArray(Name)
  If blnRet = True Then
    Call m_objOraDatabase.Parameters.Add(Name, Value, ServerType, Derection)
  End If
  ParamsAdd = blnRet
End Function

Public Function ParamsGetValue(ByVal Name As String) As Variant
  On Error GoTo SkipErrPos
  ParamsGetValue = m_objOraDatabase.Parameters(Name).Value
  Exit Function
SkipErrPos:
  ParamsGetValue = ""
End Function

Public Sub ParamsSetServerType(ByVal Name As String, ByVal ServerType As OraServerType)
  On Error GoTo SkipErrPos
  m_objOraDatabase.Parameters(Name).ServerType = ServerType
SkipErrPos:
  Exit Sub
End Sub

Private Function doDbError() As Long
  'Screen.ActiveForm.Name
  If Not m_objOraDatabase Is Nothing Then
    m_lngDbErrId = m_objOraDatabase.LastServerErr
    m_strDbErrMsg = m_objOraDatabase.LastServerErrText
    doDbError = m_lngDbErrId
  ElseIf Not m_objOraSession Is Nothing Then
    m_lngDbErrId = m_objOraSession.LastServerErr
    m_strDbErrMsg = m_objOraSession.LastServerErrText
    doDbError = m_lngDbErrId
  Else
    m_lngDbErrId = clngError
    doDbError = clngErrNullSession
  End If
End Function

Public Function ParamsGetNum() As Integer
  ParamsGetNum = m_intParams
End Function

Public Function ParamsGetNameAt(ByVal pvintIndex As Integer) As String
  If pvintIndex > m_intParams Then
    ParamsGetNameAt = ""
    Exit Function
  End If
  ParamsGetNameAt = m_arrParams(pvintIndex)
End Function

Private Function addParamsArray(ByVal pvstrParamName As String) As Boolean
  Dim intNo As Integer
  Dim arrTem() As String
  Dim blgNew As Boolean
  blgNew = True
  ReDim arrTem(m_intParams)
  For intNo = 1 To m_intParams
    arrTem(intNo) = m_arrParams(intNo)
    If blgNew = True And m_arrParams(intNo) = pvstrParamName Then
      blgNew = False
    End If
  Next intNo
  
  If blgNew = True Then
    m_intParams = m_intParams + 1
    ReDim m_arrParams(m_intParams)
    For intNo = 1 To m_intParams - 1
      m_arrParams(intNo) = arrTem(intNo)
    Next intNo
    m_arrParams(m_intParams) = pvstrParamName
  End If
  ReDim arrTem(0)
  addParamsArray = blgNew
End Function

Private Function removeParamsArray(ByVal pvstrParamName As String) As Boolean
  Dim intNo As Integer
  Dim arrTem() As String
  Dim blnRet As Boolean
  blnRet = False
  For intNo = 1 To m_intParams
    If m_arrParams(intNo) = pvstrParamName Then
      blnRet = True
      Exit For
    End If
  Next intNo
  
  If blnRet = True Then
    ReDim arrTem(m_intParams - 1)
    Dim intJ As Integer
    intJ = 1
    For intNo = 1 To m_intParams
      If m_arrParams(intNo) <> pvstrParamName Then
        arrTem(intJ) = m_arrParams(intNo)
        intJ = intJ + 1
      End If
    Next intNo
  
    m_intParams = m_intParams - 1
    ReDim m_arrParams(m_intParams)
    For intNo = 1 To m_intParams
      m_arrParams(intNo) = arrTem(intNo)
    Next intNo
    ReDim arrTem(0)
    blnRet = True
  End If
  
  removeParamsArray = True
End Function

Public Sub ParamsRemoveAll()
  On Error GoTo SkipEnd
  Dim intNo As Integer
  If m_objOraDatabase Is Nothing Then
    GoTo SkipEnd
  End If
  For intNo = 1 To m_intParams
    Call m_objOraDatabase.Parameters.Remove(m_arrParams(intNo))
  Next intNo
SkipEnd:
  ReDim m_arrParams(0)
  m_intParams = 0
End Sub