愚者の経験

「また今度」はほとんどこない

日別アーカイブ: 11月 24, 2011

VBAからODBC APIを使う 実行編(改良版)

前の記事:VBAからODBC APIを使う 実行編

SQLBindColを利用した値の取得方法がわかりましたので紹介します。
改良の余地はまだあると思いますが大まかにはこれであってると思います。

接続、SQL文発行、スタンドアロンレコードセットを作成するクラスモジュールの一部。

Private Declare Function GlobalAlloc Lib “kernel32” ( _
                ByVal wFlags As Long, _
                ByVal dwBytes As Long) As Long
               
Private Declare Function GlobalFree Lib “kernel32” ( _
                ByVal hMem As Long) As Long
               
Private Declare Function GlobalLock Lib “kernel32” ( _
                ByVal hMem As Long) As Long
               
Private Declare Function GlobalUnlock Lib “kernel32” ( _
                ByVal hMem As Long) As Long
Private Const GMEM_MOVEABLE = &H2
Private Declare Sub CopyMemory Lib “kernel32” _
                Alias “RtlMoveMemory” ( _
                Destination As Any, _
                Source As Any, _
                ByVal Length As Long)
Private Declare Function SQLBindCol Lib “odbc32.dll” ( _
                ByVal hstmt As Long, _
                ByVal iCol As Integer, _
                ByVal fCType As Integer, _
                ByRef rgbValue As Any, _
                ByVal cbValueMax As Long, _
                ByRef pcbValue As Long) As Integer
 
 
‘構造体(SQLDiscribeColで得た列情報と、
‘GlobalAllocによるメモリハンドルとGlobalLockによるポインタ、
‘さらに対応するADODB.Fieldオブジェクトを格納する)
Private Type ODBCField
    FieldName As String
    NameLength As Integer
    FieldType As Integer
    FieldSize As Long
    pDecimal As Integer
    pNull As Integer
    lp As Long
    hMem As Long
    ADO_Field As ADODB.Field
End Type

Public Sub Execute(Statement As String, Optional ExecuteOnly As Boolean = False)
On Error GoTo ExecuteErr

    Dim Ret As ODBCResultEnum
   
    ‘ステートメントハンドル作成
    ODBCErrMsg = “ステートメントハンドルの作成に失敗”
    If CreateHandle(SQL_HANDLE_STMT, hdbc, hstmt) SQL_SUCCESS Then GoTo ExecuteErr
   
    If ExecuteOnly = True Then
        ‘実行のみ
        Ret = SQLExecDirect(hstmt, Statement, SQL_NTS)
    Else
        ‘データを返す(レコードセットを作成する)
        Dim i As Long
        Dim O_Field() As ODBCField
        Dim pcbValue As Long
        Dim Value() As Byte
       
        Ret = SQLPrepare(hstmt, Statement, SQL_NTS)
        Ret = SQLNumResultCols(hstmt, Column)
        ‘構文エラーはここで処理する
        If (Ret = SQL_SUCCESS) + (Ret = SQL_SUCCESS_WITH_INFO) = False Then
            Dim NativeErr As Long
            Dim SQLState As String
            Dim pcbErrorMsg As Integer
           
            SQLState = String$(10, 0)
            ODBCErrMsg = String$(512, 0)
           
            SQLGetDiagRec SQL_HANDLE_STMT, hstmt, 1, SQLState, NativeErr, ODBCErrMsg, Len(ODBCErrMsg), pcbErrorMsg
            ODBCErrMsg = Left$(ODBCErrMsg, InStr(ODBCErrMsg, Chr(0)) – 1)
            GoTo ExecuteErr
        End If
        ‘取得した列数に基づき構造体配列数を確定
        ReDim O_Field(Column – 1)
        ‘スタンドアロンレコードセット
        Set RS_ODBC = New ADODB.Recordset
       
        For i = 0 To Column – 1
            With O_Field(i)
                ‘列名のバッファ
                .FieldName = String$(32, Chr(0))
                ‘列情報の取得
                SQLDescribeCol hstmt, i + 1, .FieldName, 32, .NameLength, .FieldType, .FieldSize, .pDecimal, .pNull
                .FieldName = Left$(.FieldName, InStr(.FieldName, Chr(0)) – 1)
               
                ‘列情報に基づきレコードセットにフィールド作成
                RS_ODBC.Fields.Append .FieldName, adLongVarWChar, .FieldSize
                ‘本当は対応するデータ型を設定したかったのだが…
‘                RS_ODBC.Fields.Append .FieldName, CADOType(.FieldType), .FieldSize
               
                ‘データの格納領域を指定
                .hMem = GlobalAlloc(GMEM_MOVEABLE, .FieldSize + 1)
                .lp = GlobalLock(.hMem)
                
                ‘第4引数はポインタなのでByvalを指定する。
                Ret = SQLBindCol(hstmt, i + 1, SQL_C_CHAR, ByVal .lp, .FieldSize + 1, pcbValue)
           
            End With
        Next
       
        ‘SQL文の実行、レコードセットオープン
        Ret = SQLExecute(hstmt)
        RS_ODBC.Open
       
        On Error GoTo FetchErr
       
        ‘ADODB.Fieldオブジェクトをセット(高速化を図る)
        For i = 0 To Column – 1
            Set O_Field(i).ADO_Field = RS_ODBC.Fields(O_Field(i).FieldName)
        Next
        
        ODBCErrMsg = “データの取り出しに失敗”
        Do Until Fetch(hstmt) = SQL_NO_DATA_FOUND
            ‘レコードセットにデータを追加
            RS_ODBC.AddNew
            For i = 0 To Column – 1
                With O_Field(i)
                    ‘ポインタにある列の値を取得する
                    .ADO_Field.Value = DataEject(.lp, .FieldSize + 1, .FieldType)
                End With
            Next
        Loop
    End If
   
    ‘メモリを解放する。
    For i = 0 To Column – 1
        GlobalUnlock O_Field(i).hMem
        GlobalFree O_Field(i).hMem
    Next
    Exit Sub
FetchErr:
    For i = 0 To Column – 1
        GlobalUnlock O_Field(i).hMem
        GlobalFree O_Field(i).hMem
    Next
ExecuteErr:
    Beep
    MsgBox ODBCErrMsg, vbInformation, “エラー”
End Sub
‘SQLDiscribeColで得たデータ型をADODBのデータ型に変換
Private Function CADOType(FieldType As Integer) As ADODB.DataTypeEnum
    Select Case FieldType
        Case SQL_CHAR: CADOType = adLongVarWChar
        Case SQL_INTEGER: CADOType = adInteger
        Case SQL_SMALLINT: CADOType = adSmallInt
        Case SQL_FLOAT: CADOType = adDouble
        Case SQL_REAL: CADOType = adDouble
        Case SQL_DOUBLE: CADOType = adDouble
        Case SQL_DATETIME: CADOType = adDate
        Case SQL_VARCHAR: CADOType = adLongVarWChar
        Case SQL_VARCHARMAX: CADOType = adLongVarWChar
        Case SQL_TIMESTAMP: CADOType = adDBTimeStamp
        Case SQL_VERBINARY: CADOType = adLongVarBinary
        Case SQL_BIGINT: CADOType = adBigInt
        Case SQL_TINYINT: CADOType = adTinyInt
        Case SQL_BIT: CADOType = adBoolean
        Case SQL_NCHAR: CADOType = adLongVarWChar
        Case SQL_NVARCHAR: CADOType = adLongVarWChar
        Case SQL_NVARCHARMAX: CADOType = adLongVarWChar
        Case SQL_GUID: CADOType = adGUID
        Case SQL_VARIANT: CADOType = adVariant
        Case SQL_MONEY: CADOType = adCurrency
    End Select
End Function
Public Property Get Recordset() As ADODB.Recordset
    Set Recordset = RS_ODBC
End Property
‘ODBCAPIの返り値は直接条件分岐に使うとおかしな値が返る場合があるので
‘Functionをかませる。
Private Function Fetch(hstmt As Long) As Integer
    Fetch = SQLFetch(hstmt)
End Function
‘ポインタから値を取得し、データ型に応じて値を変換する(CopyMemory使用)
Private Function DataEject(lp As Long, Length As Long, FieldType As Integer) As Variant
    Dim Temp() As Byte
    ReDim Temp(Length)
    CopyMemory Temp(0), ByVal lp, Length
    DataEject = StrConv(Temp, vbUnicode)
    DataEject = Left$(DataEject, InStr(DataEject, Chr(0)) – 1)
   
    Select Case FieldType
        Case SQL_CHAR, SQL_VARCHAR, SQL_VARCHARMAX, SQL_NCHAR, SQL_NVARCHAR, SQL_NVARCHARMAX, SQL_VARIANT
        Case SQL_INTEGER, SQL_SMALLINT, SQL_BIGINT, SQL_TINYINT
            DataEject = CLng(DataEject)
        Case SQL_FLOAT, SQL_REAL, SQL_MONEY
            DataEject = CCur(DataEject)
        Case SQL_DOUBLE
            DataEject = CDbl(DataEject)
        Case SQL_DATETIME
            DataEject = CDate(Left$(DataEject, 19))
        Case SQL_TIMESTAMP
        Case SQL_VERBINARY
        Case SQL_BIT
            DataEject = CBool(DataEject)
        Case SQL_GUID
            DataEject = “{” & DataEject & “}”
    End Select
End Function
‘種類別に各ハンドルを作成する
Private Function CreateHandle(HandleType As HandleTypeEnum, InputHandle As Long, OutputHandle As Long) As ODBCResultEnum
    Select Case HandleType
        Case SQL_HANDLE_ENV
            CreateHandle = SQLAllocEnv(OutputHandle)
        Case SQL_HANDLE_DBC, SQL_HANDLE_STMT, SQL_HANDLE_DESC
            CreateHandle = SQLAllocHandle(HandleType, InputHandle, OutputHandle)
    End Select
End Function
広告