oo4o 接続

'接続情報
Public Const sInstance = "XXX.X.X.X/XXXX"
Public Const sUser = "XXXXXXX"
Public Const sPassword = "XXXXXXX"
'接続情報設定変数
Public OraSess As Object
Public OraDB As Object
Public OraDS As Object

'*******************************
' データベース接続処理（Oracle）
'*******************************
Public Sub DB_Connect()
 
    'オブジェクト作成
    Set OraSess = CreateObject("OracleInProcServer.XOraSession")
    Set OraSess = New OraSessionClass
    'DB接続
    Set OraDB = OraSess.OpenDatabase(sInstance, sUser & "/" & sPassword, ORADB_DEFAULT)

End Sub

'*******************************
' データベース解放処理（Oracle）
'*******************************
Public Sub DB_DisConnect()
 
    Set OraDB = Nothing
    Set OraSess = Nothing

End Sub

'*******************************
' Select実行処理（Oracle）
' ＳＱＬ、ヘッダー有無
' 値
'*******************************
Public Function DB_SelectEnter(ByVal strSql As String, ByVal flgHeader As Boolean) As String
 
 
    Dim intCol As Integer
    Dim intRow As Integer
    Dim strReturnTitle As String
    Dim strReturnData As String
    Call DB_Connect
    '--------
    ' 参照系
    '--------
    'SQLセット
    Set OraDS = OraDB.CreateDynaset(strSql, ORADYN_READONLY)
    '結果取得
    With OraDS
   
        If flgHeader = True Then
            For intCol = 1 To .Fields.Count
                If intCol = 1 Then
                    strReturnTitle = .Fields(intCol - 1).Name
                Else
                    strReturnTitle = strReturnTitle & vbTab & .Fields(intCol - 1).Name
                End If
            Next intCol
        Else
            strReturnTitle = ""
        End If

        strReturnData = ""
        '件数カウント
        If .RecordCount <> 0 Then
            '対象レコード分ループ
            intRow = 1
            Do Until .EOF
                If intRow = 1 Then
                    For intCol = 1 To .Fields.Count
                        If intCol = 1 Then
                            strReturnData = IIf(IsNull(.Fields(intCol - 1).Value), "", .Fields(intCol - 1).Value)
                        Else
                            strReturnData = strReturnData & vbTab & IIf(IsNull(.Fields(intCol - 1).Value), "", .Fields(intCol - 1).Value)
                        End If
                    Next intCol
                Else
                    For intCol = 1 To .Fields.Count
                        If intCol = 1 Then
                            strReturnData = strReturnData & vbCrLf & IIf(IsNull(.Fields(intCol - 1).Value), "", .Fields(intCol - 1).Value)
                        Else
                            strReturnData = strReturnData & vbTab & IIf(IsNull(.Fields(intCol - 1).Value), "", .Fields(intCol - 1).Value)
                        End If
                    Next intCol
                End If
                '次のレコードへ
                intRow = intRow + 1
                .DbMoveNext
            Loop
        End If
    End With
    If flgHeader = True Then
        ClipBoadCopy (strReturnTitle & vbCrLf & strReturnData)
    Else
        ClipBoadCopy (strReturnData)
    End If
   
    GoTo Obj_Rls:
 
'------------
' エラー処理
'------------
Err_Han:
    MsgBox (Err.Description)
 
'----------
' 開放処理
'----------
Obj_Rls:
    DB_DisConnect
    Set OraDS = Nothing

End Function

'*******************************
' Select実行処理（Oracle）
' ＳＱＬ、ヘッダー有無
' 値
'*******************************
Public Sub DB_ExecuteEnter(ByVal strSql As String)
 
 
    Call DB_Connect
    'SQL実行
    OraDB.ExecuteSQL (strSql)
   
    GoTo Obj_Rls:
 
'------------
' エラー処理
'------------
Err_Han:
    MsgBox (Err.Description)
 
'----------
' 開放処理
'----------
Obj_Rls:
    DB_DisConnect

End Sub

'*******************************
' ストリングをクリップボードへ出力
'*******************************
Public Sub ClipBoadCopy(ByVal strData As String)
    Dim buf As String
    Dim CB As New MSForms.DataObject
    With CB
        .SetText strData    ''変数のデータをDataObjectに格納する
        .PutInClipboard     ''DataObjectのデータをクリップボードに格納する
    End With
End Sub