【VBA】いまさらADO、されどADO

' グローバルのConnection、閉じ忘れに注意
Public cn As New ADODB.Connection
' dsnファイルの共有パス
Public Const cnString As String = "FILEDSN=\\127.0.0.1\odbcdsn\HogeDb.dsn;"

' コネクションを確立する
Public Sub CnOpen(Optional cnn As ADODB.Connection)
    On Error GoTo Catch
    If cnn Is Nothing Then Set cnn = cn
    If cnn Is Nothing Then
        cnn.ConnectionString = cnString
    ElseIf cnn.ConnectionString = "" Then
        cnn.ConnectionString = cnString
    End If
    If cnn.State <> adStateOpen Then cnn.Open
    Exit Sub
Catch:
    OutputError "ModuleDbTools.CnOpen"
End Sub

' コネクションを閉じる
Public Sub CnClose(Optional cnn As ADODB.Connection)
    On Error GoTo Catch
    If cnn Is Nothing Then Set cnn = cn
    If cnn.State <> adStateClosed Then cnn.Close
    Exit Sub
Catch:
    OutputError "ModuleDbTools.CnClose"
    Set cnn = Nothing
End Sub

' レコードセットを取得する
Public Function GetRs(sql As String, Optional cursorType As CursorTypeEnum = adOpenKeyset, Optional lockType As LockTypeEnum = adLockOptimistic) As ADODB.Recordset
    On Error GoTo Catch
    Dim rs As New ADODB.Recordset
    CnOpen
    rs.CursorLocation = adUseClient
    rs.Open sql, cn, cursorType, lockType
    Set GetRs = rs
Finally:
    Set rs = Nothing 
    Exit Function
Catch:
    OutputError "ModuleDbTools.GetRs", sql
    GoTo Finally
End Function

' 1レコード目の1列目だけを取得する
Public Function ExecuteScalar(ByVal sql As String) As Variant
    On Error GoTo Catch
    Dim cmd As New ADODB.Command
    Dim rs As ADODB.Recordset
    CnOpen
    cmd.ActiveConnection = cn
    cmd.CommandType = adCmdText
    cmd.CommandText = sql
    Set rs = cmd.Execute()
    If rs.EOF Then
        ExecuteScalar = Empty
    Else
        ExecuteScalar = xNz(rs.Fields(0).Value)
    End If
Finally:
    Call RsClose(rs)
    Set cmd = Nothing
    Exit Function
Catch:
    OutputError "ModuleDbTools.ExecuteScalar", sql
    ExecuteScalar = Empty
    GoTo Finally
End Function

' SQLを実行する（レコードセットなし）
Public Function ExecuteNonQuery(sql As String) As Long
    Dim cnt As Long
    Dim cmd As New ADODB.Command
    On Error GoTo Catch
    cnt = -1
    CnOpen
    cmd.ActiveConnection = cn
    cmd.CommandType = adCmdText
    cmd.CommandText = sql
    cmd.Execute cnt
    ExecuteNonQuery = cnt
Finally:
    Set cmd = Nothing
    Exit Function
Catch:
    OutputError "ModuleDbTools.ExecuteNonQuery", sql
    GoTo Finally
End Function

' 指定したシートにデータを呼び出す
Public Function GetData(sh As Worksheet, sql As String, _
                        Optional withTitle As Boolean = False, _
                        Optional specifyRow As Long = 1, _
                        Optional insertRange As Boolean = False) As Long
    On Error GoTo Catch
    Dim rs As ADODB.Recordset: Set rs = GetRs(sql)
    If rs.EOF Then GoTo Finally
    If sh.FilterMode Then sh.ShowAllData
    Dim rwCnt As Long: rwCnt = rs.RecordCount
    If withTitle Then rwCnt = rwCnt + 1
    Dim cmCnt As Long: cmCnt = rs.Fields.Count
    Dim lst() As Variant: ReDim lst(rwCnt - 1, cmCnt - 1) As Variant
    Dim cm As Long, rwBgn As Long
    If withTitle Then
        For cm = 0 To cmCnt - 1
            lst(0, cm) = rs.Fields(cm).Name
        Next
        rwBgn = 1
    End If
    Dim rw As Long
    For rw = rwBgn To rwCnt - 1
        For cm = 0 To cmCnt - 1
            If IsNull(rs.Fields(cm).Value) Then
                lst(rw, cm) = Empty
            ElseIf rs.Fields(cm).Type = adBoolean Then
                If rs.Fields(cm).Value Then
                    lst(rw, cm) = 1
                Else
                    lst(rw, cm) = Empty
                End If
            Else
                lst(rw, cm) = rs.Fields(cm).Value
            End If
        Next
        rs.MoveNext
    Next
    If insertRange Then
        If Application.CutCopyMode Then Application.CutCopyMode = False
        sh.Range("A" & specifyRow).Resize(rwCnt).EntireRow.Insert , xlFormatFromRightOrBelow
    End If
    sh.Range("A" & specifyRow, sh.Cells(rwCnt + specifyRow - 1, cmCnt)).Value = lst
    GoTo Finally
Catch:
    Select Case Err.Number
    Case 13
        Err.Clear
    Case Else
        MsgBox Err.Description, vbExclamation
        rw = 0
    End Select
    OutputError "ModuleDbTools.GetData", sql
Finally:
    RsClose rs
    GetData = rw
End Function

' AccessのNz関数のようなもの
Public Function xNz(X As Variant, Optional vl As Variant = Empty) As Variant
    On Error GoTo Catch
    If IsNull(X) Then
        xNz = vl
    Else
        xNz = X
    End If
    Exit Function
Catch:
    OutputError "ModuleDbTools.xNz"
End Function

' レコードセットを閉じる定型文をプロシージャ化
Public Sub RsClose(rs As ADODB.Recordset)
    If Not rs Is Nothing Then
        If rs.State <> ObjectStateEnum.adStateClosed Then rs.Close
    End If
End Sub

' エラーメッセージ出力
Public Sub OutputError(errPlace As String, Optional errNote As String)
    Dim msg As String
    msg = vbCrLf
    msg = "日時：" & Format$(Now(), "yyyy/mm/dd hh:nn:ss") & vbCrLf
    msg = msg & "ソース：" & Err.Source & vbCrLf
    msg = msg & "ブック名：" & ActiveWorkbook.Name & vbCrLf
    msg = msg & "場所：" & errPlace & vbCrLf
    msg = msg & "備考：" & errNote & vbCrLf
    msg = msg & "エラー番号：" & Err.Number & vbCrLf
    msg = msg & "エラー内容：" & Err.Description & vbCrLf
    Debug.Print msg
End Sub

Sub Hoge1()

    Dim sql As String
    sql = "INSERT INTO 映画 (題名,製作,上映時間,興行収入) VALUES "
    sql = sql & "('続夕陽のガンマン',1966,'2:59:00',25100000),"
    sql = sql & "('カッコーの巣の上で',1975,'2:13:00',108981275),"
    sql = sql & "('天国から来たチャンピオン',1978,'1:41:00',81640278),"
    sql = sql & "('ブレードランナー',1982,'1:56:00',32868943)"
    
    Dim cnt As Long
    cnt = ExecuteNonQuery(sql)
    ' 4件のデータを登録したのでcntには4が代入される
    Debug.Print cnt & "件追加"
    
    Call CnClose

End Sub

Sub Hoge2()

    Dim sql As String
    sql = "SELECT * FROM 映画"
    
    Dim cnt As Long
    cnt = GetData(Sheet1, sql, True)
    
    Call CnClose

End Sub

Sub Hoge3()
    
    Dim sql As String
    sql = "SELECT 題名,上映時間 FROM 映画"
    
    Dim rs As ADODB.Recordset
    Set rs = GetRs(sql)
    
    Do Until rs.EOF
        If xNz(rs.Fields("題名").Value) = "ブレードランナー" Then
            rs.Fields("上映時間").Value = "1:57:00"
            rs.Update
        End If
        rs.MoveNext
    Loop

    Call RsClose(rs)
    Call CnClose
    
End Sub