Option Explicit
'******************************************************************************
' Name        : DB
' Description : 一个使用oo4o方式访问Oracle数据库的模块
' Author      : junglesong (hey@dhc.com.cn,junglesong@gmail.com)
'******************************************************************************

'// CreateDynaset Method Options
Public Const ORADYN_DEFAULT = &H0&      '// 更新（ロック）モード
Public Const ORADYN_READONLY = &H4&     '// 読取り専用モード

Public gOraSession          As Object
Public gOraDatabase         As Object
Public gstrSQL              As String
'*******************************************************************************
'*    関数名    ：  openOracleDb                                               *
'*    概要      ：  データベースを開く                                         *
'*    機能      ：  データベースを開く                                         *
'*                                                                             *
'*    入出力仕様：  なし                                                       *
'*    リターン値：  0           :   成功                                       *
'*                  1           :   失敗                                       *
'*    作成者    ：  junglesong@gmail.com                                                       *
'*    作成日    ：  2005.08.11                                                 *
'*******************************************************************************
Public Function openOracleDb() As Integer
'On Error GoTo ERR_LBL               '// ｴﾗｰﾄﾗｯﾌﾟ開始

    '// ｾｯｼｮﾝｵｰﾌﾟﾝ
    '//Set aa = New OracleInProcServer
   
    Set gOraSession = CreateObject("OracleInProcServer.XOraSession")

    '// DBｵｰﾌﾟﾝ
    Set gOraDatabase = gOraSession.OpenDatabase(gstrHost, gstrUser & "/" & gstrPass, ORADYN_DEFAULT)

    '// 正常終了
    openOracleDb = 0
    Debug.Print ("データベースと接続できる")
   
    Exit Function

ERR_LBL:
    'エラーメッセージ表示
    Dim strErr As String
    strErr = strErr + "ｴﾗｰ番号:" + CStr(Err.Number) + vbCrLf + "ｴﾗｰ説明:" + Err.Description
    strErr = strErr + "Host:" + gstrHost + "　User:" + gstrUser + "　Password:" + gstrPass + "でデータベースへ接続できません"
   
    MsgBox strErr, vbCritical, "データベース接続できません"
    '異常終了
    openOracleDb = 1
    Debug.Print ("データベースと接続できません")
    End
   

End Function
'*******************************************************************************
'*    関数名    ：  closeOracleDb                                              *
'*    概要      ：  データベースを閉じる                                       *
'*    機能      ：  データベースを閉じる                                       *
'*                                                                             *
'*    入出力仕様：  なし                                                       *
'*    リターン値：  0           :   成功                                       *
'*                  1           :   失敗                                       *
'*    作成者    ：  junglesong@gmail.com                                                       *
'*    作成日    ：  2005.08.11                                                 *
'*******************************************************************************
Public Function closeOracleDb() As Integer
On Error GoTo ERR_LBL               '// ｴﾗｰﾄﾗｯﾌﾟ開始

    Set gOraDatabase = Nothing          '// DBｸﾛｰｽﾞ
    Set gOraSession = Nothing           '// ｾｯｼｮﾝｸﾛｰｽﾞ

    '正常終了
    closeOracleDb = 0
    Debug.Print ("データベースクロース成功")

    Exit Function

ERR_LBL:
    '// エラーメッセージ表示
    MsgBox " ｴﾗｰ番号 : " & Err & Err.Description, vbCritical, "ﾃﾞｰﾀﾍﾞｰｽｸﾛｰｽﾞ関数"
    '// 異常終了
    closeOracleDb = 1
    Debug.Print ("データベースクロース失敗")
    On Error GoTo 0
   
End Function
'*******************************************************************************
'*    関数名    ：  terminateOracleDb                                          *
'*    概要      ：  プログラムを退出                                           *
'*    機能      ：  プログラムを退出                                           *
'*                                                                             *
'*    入出力仕様：  なし                                                       *
'*    リターン値：  なし                                                       *
'*    作成者    ：  junglesong@gmail.com                                                       *
'*    作成日    ：  2005.08.11                                                 *
'*******************************************************************************
Public Function terminateOracleDb()
    Call closeOracleDb
End Function
'*******************************************************************************
'*    関数名    ：  dBnewTrans                                                 *
'*    概要      ：  トランザクションを開始する                                 *
'*    機能      ：  トランザクションを開始する                                 *
'*                                                                             *
'*    入出力仕様：  なし                                                       *
'*    リターン値：  0           :   成功                                       *
'*                  1           :   失敗                                       *
'*    作成者    ：  junglesong@gmail.com                                                       *
'*    作成日    ：  2005.08.11                                                 *
'*******************************************************************************
Public Function dBnewTrans() As Integer
On Error GoTo ERR_LBL   '// ｴﾗｰﾄﾗｯﾌﾟ開始

    gOraSession.BeginTrans         '// ﾄﾗﾝｻﾞｸｼｮﾝ開始

    '// 正常終了
    dBnewTrans = 0
    Debug.Print ("データベースの変動を記録始める")

    Exit Function
ERR_LBL:
    '// エラーメッセージ表示
    MsgBox " ｴﾗｰ番号 : " & Err & Err.Description, vbCritical, "ﾄﾗﾝｻﾞｸｼｮﾝ開始関数"
    '// 異常終了
    dBnewTrans = 1
    Debug.Print ("データベース変動失敗")
    On Error GoTo 0
End Function
'*******************************************************************************
'*    関数名    ：  dbCommit                                                   *
'*    概要      ：  コミットを発行する                                         *
'*    機能      ：  コミットを発行する                                         *
'*                                                                             *
'*    入出力仕様：  なし                                                       *
'*    リターン値：  0           :   成功                                       *
'*                  1           :   失敗                                       *
'*    作成者    ：  junglesong@gmail.com                                                       *
'*    作成日    ：  2005.08.11                                                 *
'*******************************************************************************
Public Function dbCommit() As Integer
On Error GoTo ERR_LBL   '// ｴﾗｰﾄﾗｯﾌﾟ開始

    gOraSession.CommitTrans        '// ｺﾐｯﾄ

    '// 正常終了
    dbCommit = 0
    Debug.Print ("データベースの変動コミット成功")

    Exit Function

ERR_LBL:
    '// エラーメッセージ表示
    MsgBox " ｴﾗｰ番号 : " & Err & Err.Description, vbCritical, "ｺﾐｯﾄ実行関数"
    '// 異常終了
    dbCommit = 1
    Debug.Print ("データベースの変動コミット失敗")
    On Error GoTo 0
End Function
'*******************************************************************************
'*    関数名    ：  dBRollback                                                 *
'*    概要      ：  ロールバックを発行する                                     *
'*    機能      ：  ロールバックを発行する                                     *
'*                                                                             *
'*    入出力仕様：  なし                                                       *
'*    リターン値：  0           :   成功                                       *
'*                  1           :   失敗                                       *
'*    作成者    ：  junglesong@gmail.com                                                       *
'*    作成日    ：  2005.08.11                                                 *
'*******************************************************************************
Public Function dBRollback()
On Error GoTo ERR_LBL   '// ｴﾗｰﾄﾗｯﾌﾟ開始

    gOraSession.Rollback           '// ﾛｰﾙﾊﾞｯｸ

    '// 正常終了
    dBRollback = 0
    Debug.Print ("データベース変動rollback成功")

    Exit Function

ERR_LBL:
    '// エラーメッセージ表示
    MsgBox " ｴﾗｰ番号 : " & Err & Err.Description, vbCritical, "ﾛｰﾙﾊﾞｯｸ実行関数"
    '// 異常終了
    dBRollback = 1
    Debug.Print ("データベース変動rollback失敗")
    On Error GoTo 0
End Function
'*******************************************************************************
'*    関数名    ：  executeSql                                                 *
'*    概要      ：  Execute SQLを実行する                                      *
'*    機能      ：  Execute SQLを実行する                                      *
'*                                                                             *
'*    入出力仕様：  SQL As String  I  実行するSQL文                            *
'*    リターン値：  0           :   成功                                       *
'*                  1           :   失敗                                       *
'*    作成者    ：  junglesong@gmail.com                                                       *
'*    作成日    ：  2005.08.11                                                 *
'*******************************************************************************
Public Function executeSql(sql As String) As Integer
    Dim Ss As Date
    Dim Ct As Integer

    '変数の初期化
    Ct = 0

On Error Resume Next

ReTRAI:

    '// SQL文実行する
    gOraDatabase.executeSql (sql)
   
    '// DML文をログファイルに記入する
    Debug.Print (sql)

    Select Case Err
           Case 0:      '// SQL文実行正確
                Debug.Print ("SQL文実行正確")
           Case 3260:   '// 排他ロック状態
                Debug.Print ("データベースは排他ロック状態")
                Ct = Ct + 1
                Ss = DateAdd("s", 1, Now)
                Do Until Ss < Now
                   DoEvents
                Loop
                If Ct < 3 Then   '３回リトライする。
                   Err = 0
                   GoTo ReTRAI
                End If
    End Select

    If Err <> 0 Then
        '// エラーメッセージ表示
        MsgBox " ｴﾗｰ番号 : " & Err & Err.Description, vbCritical, "SQL実行関数"
        Debug.Print ("SQL語句執行ｴﾗｰ:" + " ｴﾗｰ番号 : " + Err + Err.Description)
        '// 異常終了
        executeSql = 1
        Debug.Print ("SQL語句執行ｴﾗｰ:" + " ｴﾗｰ番号 : " + Err + Err.Description)
    End If
    Err = 0

On Error GoTo 0

End Function
'*******************************************************************************
'*    関数名    ：  getDbSysDate                                               *
'*    概要      ：  サーバーのシステム日付+時間を取得する                      *
'*    機能      ：  サーバーのシステム日付+時間を取得する                      *
'*                                                                             *
'*    入出力仕様：  RetSts As Integer  I  0 : 正常終了、1 : 異常終了           *
'*                  SrvDate As Date    I  サーバーのシステム日付               *
'*    リターン値：  なし                                                       *
'*    作成者    ：  junglesong@gmail.com                                                       *
'*    作成日    ：  2005.08.11                                                 *
'*******************************************************************************
Public Sub getDbSysDate(RetSts As Integer, SrvDate As Date)
On Error GoTo ERR_LBL   '// ｴﾗｰﾄﾗｯﾌﾟ開始

    Dim OraDynaset As Object

    '// 引数初期化
    RetSts = 0
    SrvDate = Empty

    '// ｼｽﾃﾑ日付を取得(Date型)
    gstrSQL = "SELECT SYSDATE FROM DUAL"

    Set OraDynaset = gOraDatabase.DbCreateDynaset(gstrSQL, ORADYN_READONLY)

    SrvDate = OraDynaset(0).value

    Set OraDynaset = Nothing

    Exit Sub

ERR_LBL:
    '// エラーメッセージ表示
    MsgBox " ｴﾗｰ番号 : " & Err & Err.Description, vbCritical, "ｻｰﾊﾞｰｼｽﾃﾑ日付取得関数"
    '// 異常終了
    RetSts = 1
    On Error GoTo 0
End Sub
'*******************************************************************************
'*    関数名    ：  handleSql                                                  *
'*    概要      ：  strSqlを引数としてDBを操作する                             *
'*    機能      ：  strSqlを引数としてDBを操作する                             *
'*                                                                             *
'*    入出力仕様：  strSql As String  I  セレクト文                            *
'*    リターン値：  なし                                                       *
'*    作成者    ：  junglesong@gmail.com                                                       *
'*    作成日    ：  2005.08.11                                                 *
'*******************************************************************************
Public Function handleSql(strSql As String)
    Dim RetSts As Integer
   
    RetSts = dBnewTrans
    If RetSts > 0 Then
        Debug.Print ("newTrans異常終了")
        Exit Function
    End If
   
    If executeSql(strSql) > 0 Then
        '// Rollback異常終了
        RetSts = dBRollback
       
        Debug.Print ("Rollback異常終了")
        Exit Function
    End If
   
    '// データベースの変動を確認する
    RetSts = dbCommit

    If RetSts > 0 Then
        '// Commit異常終了
        RetSts = dBRollback
       
        Debug.Print ("Commit異常終了")
        Exit Function
    End If
   
End Function
'*******************************************************************************
'*    関数名    ：  changeNull                                                 *
'*    概要      ：  NULLの時、""を返す                                         *
'*    機能      ：  NULLの時、""を返す                                         *
'*                                                                             *
'*    入出力仕様：  varData As Variant  I  変換するデータ                      *
'*    リターン値：  changeNull：変換したデータ                                 *
'*    作成者    ：  junglesong@gmail.com                                                       *
'*    作成日    ：  2005.08.11                                                 *
'*******************************************************************************
Public Function changeNull(varData As Variant) As String
On Error GoTo errorproc

    If (IsNull(varData)) Then
        changeNull = ""
    Else
        changeNull = CStr(varData)
    End If
   
    Exit Function
errorproc:
    changeNull = ""
End Function

'*******************************************************************************
'*    関数名    ：  get2dArrayBySql                                            *
'*    概要      ：  SQl文からグループを数えることを得る                        *
'*    機能      ：  SQl文からグループを数えることを得る                        *
'*                                                                             *
'*    入出力仕様：  strSql                        I  SQL 文　　　　            *
'*    リターン値：  2D array by the Sql　　　　　　　　　　　   　       　　　*
'*    作成者    ：  junglesong@gmail.com                                                       *
'*    作成日    ：  2005.10.24                                                 *
'*******************************************************************************
Public Function get2dArrayBySql(strSql As String)
    '// Setup OraDynaset to contain datum
    Dim OraDynaset As Object
    Set OraDynaset = gOraDatabase.DbCreateDynaset(strSql, ORADYN_READONLY)
   
    '// Setup a array to contain datum
    Dim arrayRetval() As String
    ReDim arrayRetval(OraDynaset.RecordCount - 1, OraDynaset.fields.Count - 1)
   
    '// Traversal the OraDynaset and put value to array
    Dim i, j As Integer
    While Not OraDynaset.EOF
        For j = 0 To OraDynaset.fields.Count - 1
            arrayRetval(i, j) = changeNull(OraDynaset.fields(j).value)
        Next
        i = i + 1
        OraDynaset.MoveNext
    Wend
   
    '// Return the array
    get2dArrayBySql = arrayRetval
End Function
'*******************************************************************************
'*    関数名    ：  get1dArrayBySql                                            *
'*    概要      ：  SQl文からグループを数えることを得る                        *
'*    機能      ：  SQl文からグループを数えることを得る                        *
'*                                                                             *
'*    入出力仕様：  strSql                        I  SQL 文　　　　            *
'*    リターン値：  2D array by the Sql　　　　　　　　　　　   　       　　　*
'*    作成者    ：  junglesong@gmail.com                                                       *
'*    作成日    ：  2005.10.24                                                 *
'*******************************************************************************
Public Function get1dArrayBySql(strSql As String)
On Error GoTo errorproc

    '// Setup OraDynaset to contain datum
    Dim OraDynaset As Object
    Set OraDynaset = gOraDatabase.DbCreateDynaset(strSql, ORADYN_READONLY)
   
    '// Setup a array to contain datum
    Dim arrayRetval() As String
    ReDim arrayRetval(OraDynaset.RecordCount - 1)
   
    '// Traversal the OraDynaset and put value to array
    Dim i, j As Integer
    While Not OraDynaset.EOF
        arrayRetval(i) = changeNull(OraDynaset.fields(0).value)
       
        i = i + 1
        OraDynaset.MoveNext
    Wend
   
    '// Return the array
    get1dArrayBySql = arrayRetval
   
Exit Function
errorproc:
    ReDim arrayRetval(0)
    get1dArrayBySql = arrayRetval
End Function
'*******************************************************************************
'*    関数名    ：  getValueBySql                                              *
'*    概要      ：  SQl文から内容を得る                                        *
'*    機能      ：  SQl文から内容を得る                                        *
'*                                                                             *
'*    入出力仕様：  strSql                        I  SQL 文　　　　            *
'*    リターン値：  2D array by the Sql　　　　　　　　　　　   　       　　　*
'*    作成者    ：  junglesong@gmail.com                                                       *
'*    作成日    ：  2005.10.24                                                 *
'*******************************************************************************
Public Function getValueBySql(strSql As String, strDefault As String)
    '// Setup OraDynaset to contain datum
    Dim OraDynaset As Object
    Set OraDynaset = gOraDatabase.DbCreateDynaset(strSql, ORADYN_READONLY)
   
    If OraDynaset.RecordCount > 0 Then
        getValueBySql = changeNull(OraDynaset.fields(0).value)
    Else
        getValueBySql = strDefault
    End If

End Function

Public Function getRecordofSql(strSql As String)
    Dim OraDynaset As Object
    Set OraDynaset = gOraDatabase.DbCreateDynaset(strSql, ORADYN_READONLY)
   
    getRecordofSql = OraDynaset.RecordCount
End Function