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

转载于:https://www.cnblogs.com/LiuShui/archive/2004/08/07/30964.html