ExcelVBA 　ACCESS連携

:::note warn
自分用のメモなので、形は整ってないです。
:::
### ADOを使ったACCESSのレコードの取得・更新
```
※ACCESS側でテーブルをデザインビューで開いているとエラーになるので、データシートビューで開くように

Sub Sample1()
'例1

  Dim adoCon As Object
  Dim adoRs As Object
  Dim path As String
  Dim sqlStr As String
  Dim xRow As Long

  path = "C:\work\テスト.accdb"

  Set adoCon = CreateObject("ADODB.Connection")
  adoCon.ConnectionString = "provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & path & ";"
  adoCon.Open

  Set adoRs = CreateObject("ADODB.Recordset") 'ADOレコードセットオブジェクトを作成
  
  sqlStr = "SELECT * FROM 数値 WHERE 整数 > 4000"
  
  Cells.Clear
  
  adoRs.Open sqlStr, adoCon
  Cells(1, 1).CopyFromRecordset adoRs
  'テーブルのデータを取得し、エクセルに出力
  'データが1件も無い場合は、何も出力されない
  
  xRow = 30
  With adoRs
    On Error Resume Next
    'データが1件も無い場合は、MoveFirstでエラーになってしまうので、エラー無視で
    .MoveFirst
    '先頭のレコードへ移動。一度全レコードの取得しているので、これが必要になる
    On Error GoTo 0
    Do Until .EOF
      Cells(xRow, 1) = !バイト
      Cells(xRow, 2) = !整数
      Cells(xRow, 3) = !長整数
      .MoveNext
      xRow = xRow + 1
    Loop
  End With
  
  
  sqlStr = "UPDATE 数値 SET 整数 = 999 WHERE 整数 > 50"
  
  adoCon.BeginTrans  'トランザクションの開始
  On Error Resume Next
  adoCon.Execute sqlStr  ' 更新の実行
  If Err.number > 0 Then  'エラーが発生している場合
    adoCon.RollbackTrans  'ロールバック
  Else
    adoCon.CommitTrans  'コミット
  End If
  On Error GoTo 0
  
  
  On Error Resume Next
  adoRs.Close
  'すでにCloseしていたり、Openしていない場合はエラーになるので、エラー無視で進めるのが適切か
  adoCon.Close
  Set adoRs = Nothing
  Set adoCon = Nothing
  On Error GoTo 0

End Sub


Sub Sample2()
'例2

  Dim adoCon As ADODB.Connection
  Dim adoRs As ADODB.Recordset
  Dim path As String
  Dim sqlStr As String
  Dim xRow As Long
  Dim i As Long

  path = "C:\work\テスト.accdb"

  Set adoCon = New ADODB.Connection
  adoCon.ConnectionString = "provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & path & ";"
  adoCon.Open

  Set adoRs = New ADODB.Recordset
  
  sqlStr = "SELECT * FROM 数値 WHERE 整数 > 30"
  
  Cells.Clear
  
  adoRs.Open sqlStr, adoCon
  
  xRow = 1
  On Error Resume Next
  'データが1件も無い場合は、MoveFirstでエラーになってしまうので、エラー無視で
  adoRs.MoveFirst
  On Error GoTo 0
  
  Do Until adoRs.EOF
    For i = 0 To adoRs.Fields.Count - 1
      If xRow = 1 Then  '1行目はフィールド名も出力
        Cells(xRow, i + 1) = adoRs(i).Name
        Cells(xRow + 1, i + 1) = adoRs(i).Value
      Else
        Cells(xRow, i + 1) = adoRs(i).Value
      End If
    Next i
    adoRs.MoveNext
    
    If xRow = 1 Then
      xRow = 3
    Else
      xRow = xRow + 1
    End If
  Loop
  
  On Error Resume Next
  adoRs.Close
  'すでにCloseしていたり、Openしていない場合はエラーになるので、エラー無視で進めるのが適切か
  adoCon.Close
  Set adoRs = Nothing
  Set adoCon = Nothing
  On Error GoTo 0

End Sub


Sub Sample3()
'例3

  Dim adoCon As ADODB.Connection
  Dim adoRs As ADODB.Recordset
  Dim path As String
  Dim xRow As Long
  Dim i As Long

  path = "C:\work\テスト.accdb"

  Set adoCon = New ADODB.Connection
  adoCon.ConnectionString = "provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & path & ";"
  adoCon.Open

  Set adoRs = New ADODB.Recordset
  
  With adoRs
    .Source = "数値"  'テーブル名
    .ActiveConnection = adoCon
    .CursorType = adOpenKeyset  'キーセットカーソルを使用
    .LockType = adLockPessimistic   'レコード単位排他的ロック
    .Open
  End With
  
  Cells.Clear
  
  xRow = 1
  On Error Resume Next
  'データが1件も無い場合は、MoveFirstでエラーになってしまうので、エラー無視で
  adoRs.MoveFirst
  On Error GoTo 0
  
  Do Until adoRs.EOF
    For i = 0 To adoRs.Fields.Count - 1
      If xRow = 1 Then  '1行目はフィールド名も出力
        Cells(xRow, i + 1) = adoRs(i).Name
        Cells(xRow + 1, i + 1) = adoRs(i).Value
      Else
        Cells(xRow, i + 1) = adoRs(i).Value
      End If
    Next i
    adoRs.MoveNext
    
    If xRow = 1 Then
      xRow = 3
    Else
      xRow = xRow + 1
    End If
  Loop
  
  
  adoCon.BeginTrans  'トランザクションの開始
  On Error Resume Next
  With adoRs
    .MoveFirst  'これは必要
    .Find "整数 = 50", 0, adSearchForward   '整数=50 のレコードへ移動
    .Fields("バイト") = 11
    .Fields("整数") = 22
    .Fields("長整数") = 33
    .Fields("単小数") = 44
    .Fields("倍小数") = 55
    .Fields("十進") = 66
    .Fields("大きい数値") = 77
    .Fields("通貨") = 88
    .Update  '更新
    
    '以下のように、ARRAYでまとめて指定して更新することもできる
'    .Update Array("整数", "長整数", "単小数"), Array(777, 888, 999)
  End With

  If Err.number > 0 Then  'エラーが発生している場合
    adoCon.RollbackTrans  'ロールバック
  Else
    adoCon.CommitTrans  'コミット
  End If
  On Error GoTo 0
  
  
  On Error Resume Next
  adoRs.Close
  'すでにCloseしていたり、Openしていない場合はエラーになるので、エラー無視で進めるのが適切か
  adoCon.Close
  Set adoRs = Nothing
  Set adoCon = Nothing
  On Error GoTo 0

End Sub
```
### ACCESSのテーブル名・クエリ名を取得する
```
'Microsoft ActiveX Data Objects *,* Library と  Microsoft ADO Ext. *.* for DDL and Security　が必要になるらしい

  Dim adoCon As Object
  Dim ac As New ADOX.Catalog
  Dim xTable As ADOX.Table
  Dim xQuery As ADOX.View
  Dim xProcedure As ADOX.Procedure
  Dim path As String
  
  path = "C:\Users\Benten\Desktop\ACCESSシステム\システム.accdb"
  
  Set adoCon = CreateObject("ADODB.Connection")
  adoCon.ConnectionString = "provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & path & ";"
  adoCon.Open
  ac.ActiveConnection = adoCon
  
  'テーブル。テーブル以外にもパラメータを持たない選択クエリが含まれる
  For Each xTable In ac.Tables
    Select Case xTable.Type
      Case "TABLE"
        Debug.Print "通常テーブル:  " & xTable.Name
      Case "VIEW"
        Debug.Print "パラメータ無し選択クエリ:  " & xTable.Name
      Case "LINK"
        Debug.Print "リンクテーブル(ODBC以外):  " & xTable.Name
      Case "ACCESS TABLE"
        Debug.Print "ACCESS システムテーブル:  " & xTable.Name
      Case "SYSTEM TABLE"
        Debug.Print "Microsoft jet システムテーブル:  " & xTable.Name
      Case "PASS-THROUGH"
        Debug.Print "リンクテーブル(ODBC):  " & xTable.Name
      Case Else
        Debug.Print "異常なオブジェクト?" & xTable.Name
    End Select
  Next xTable
  
  
  Debug.Print "*****************************************************************************"

  'クエリ
  For Each xQuery In ac.Views
    Debug.Print "パラメータ無し選択クエリ:  " & xQuery.Name
  Next xQuery

  For Each xProcedure In ac.Procedures
    Debug.Print "アクションクエリ・パラメータ付選択クエリ:  " & xProcedure.Name
  Next xProcedure
  
  
  adoCon.Close
  Set adoCon = Nothing
  Set ac = Nothing
```
### DAOを使ってレコードの取得・更新
```
※ACCESS側でテーブルをデザインビューで開いているとエラーになるので、データシートビューで開くように
※ACCESS側でテーブルをデザインビューで開いているとエラーになるので、データシートビューで開くように

Sub Sample1()
'※DAOのRecordsetは、ACCESSのレコードセットと同じように使えると思う

  Dim wks As DAO.Workspace
  Dim db As DAO.Database
  Dim rs As DAO.Recordset
  Dim path As String
  Dim criteriaStr As String
  Dim xRow As Long
  Dim i As Long

  path = "C:\work\テスト.accdb"

  Set wks = DBEngine.Workspaces(0)
  'ワークスペースの確保。Workspaces(0)とするのが定番らしいが、トラブルが多いようだ
  'ワークスペースは、トランザクションを使用するために必要となる
  
  'Set wks = CreateWorkspace("wks", "admin", "", dbUseJet)
  '上記のように、新規にワークスペースの宣言をすることも可能

  Set db = wks.OpenDatabase(path)
  Set rs = db.OpenRecordset("数値", dbOpenDynaset)
  '「数値」テーブルのRecodsetをダイナセットで開く。dbOpenDynasetの指定は必要
  
  Cells.Clear
  
  xRow = 1
  On Error Resume Next
  '取得件数が0だと、.MoveFirst でエラーになってしまうのでエラー無視で
  rs.MoveFirst  'レコードの先頭へ
  On Error GoTo 0
  Do Until rs.EOF
    For i = 0 To rs.Fields.Count - 1
      If xRow = 1 Then  '1行目はフィールド名を出力
        Cells(xRow, i + 1) = rs(i).Name
        Cells(xRow + 1, i + 1) = rs(i).Value
      Else
        Cells(xRow, i + 1) = rs(i).Value
      End If
    Next i
    rs.MoveNext
    
    If xRow = 1 Then
      xRow = 3
    Else
      xRow = xRow + 1
    End If
  Loop
  
  
  xRow = 30
  criteriaStr = "整数 > 40"
  With rs
    .FindFirst criteriaStr
    '検索条件にマッチする最初のレコードへ。Recodsetを開く時にdbOpenDynasetの指定が無いとここでエラーになるらしい
    Do Until .NoMatch
      Cells(xRow, 1) = !バイト
      Cells(xRow, 2) = !整数
      Cells(xRow, 3) = !長整数
      xRow = xRow + 1
      .FindNext criteriaStr
    Loop
  End With
  
  
  On Error Resume Next
  wks.BeginTrans   'トランザクション開始
  
  criteriaStr = "整数 > 70"
  With rs
    .FindFirst criteriaStr
    Do Until .NoMatch
      .Edit
      !バイト = !バイト + 1
      !整数 = !整数 + 1
      !長整数 = !長整数 + 1
      .Update  '更新
      .FindNext criteriaStr
    Loop
  End With
  
  If Err.number > 0 Then   'エラーが発生している場合
    wks.Rollback  'ロールバック
  Else
    wks.CommitTrans  'コミット
  End If
  On Error GoTo 0
  
  
  On Error Resume Next
  rs.Close  'すでにCloseしていたり、Openしていない場合はエラーになるので、エラー無視でいいと思う
  db.Close
  '※必須。データベースをCloseしないと、その後でWorkspaces(0)が使えなくなることがある
  wks.Close
  Set rs = Nothing
  Set db = Nothing
  Set wks = Nothing
  On Error GoTo 0
  
End Sub
```
### 	ADOでフィールドのデータ型を取得する
```
※添付ファイル型は注意が必要
Sub Sample1()
'テーブル・クエリのフィールドのデータ型を出力

  Dim adoCon As ADODB.Connection
  Dim adoRs As ADODB.Recordset
  Dim path As String
  Dim tableName As String
  Dim i As Long
  
  path = "C:\work\テスト.accdb"
  
  tableName = "全データ型"
  '全データ型のフィールドがあるテーブル
'  tableName = "Qselect_全データ型"
  '「全データ型」テーブルの全フィールドを選択しているクエリ。添付ファイル型のフィールドも含むので、エラーになる
'  tableName = "Qselect_全データ型2"
  '「全データ型」テーブルの添付ファイル型のフィールドだけ除外したクエリ。これはエラーにならない
  
  
  Set adoCon = New ADODB.Connection
  adoCon.ConnectionString = "provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & path & ";"
  adoCon.Open

  On Error GoTo ErrorHandler
  Set adoRs = New ADODB.Recordset
  With adoRs
    .Source = tableName
    .ActiveConnection = adoCon
    .Open
    '添付ファイル型のフィールドを選択しているクエリの場合、ここでエラーになる。テーブルは大丈夫
  End With
  On Error GoTo 0
  
  For i = 0 To adoRs.Fields.Count - 1
    Debug.Print "フィールド名: " & adoRs.Fields(i).Name & "   TYPE: " & adoRs.Fields(i).Type
  Next i

ReturnPoint:
  
  On Error Resume Next
  adoRs.Close
  adoCon.Close
  Set adoRs = Nothing
  Set adoCon = Nothing
  On Error GoTo 0
  
  Exit Sub
  
ErrorHandler:
  MsgBox "テーブル・クエリのOpenに失敗しました。添付ファイル型のフィールドがあるクエリを指定した可能性があります"
  Resume ReturnPoint

End Sub


Sub Sample2()
'フィールド名を指定して、データ型を取得

  Dim path As String
  Dim tableName As String
  Dim fieldName As String
  
  path = "C:\work\テスト.accdb"
  
  tableName = "全データ型"
'  tableName = "Qselect_全データ型"
'  tableName = "Qselect_全データ型2"
  
  fieldName = "数値_バイト"
'  fieldName = "添付ファイル"
'  fieldName = "存在しないフィールド"

  Debug.Print GetFieldType(path, tableName, fieldName)
  

End Sub


Function GetFieldType(path As String, tableName As String, fieldName As String) As String
'フィールドのデータ型を取得する。クエリもOK
'添付ファイル型は長いテキストと判定される

  Dim adoCon As ADODB.Connection
  Dim adoRs As ADODB.Recordset
  Dim fieldType As Long   'フィールドのデータ型を表す数値
  
  Set adoCon = New ADODB.Connection
  adoCon.ConnectionString = "provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & path & ";"
  adoCon.Open

  On Error GoTo ErrorHandler
  Set adoRs = New ADODB.Recordset
  With adoRs
    .Source = tableName
    .ActiveConnection = adoCon
    .Open
    '添付ファイル型のフィールドを選択しているクエリの場合、ここでエラーになる。テーブルは大丈夫
  End With
  On Error GoTo 0
  
  On Error GoTo ErrorHandler2
  fieldType = adoRs.Fields(fieldName).Type
  On Error GoTo 0
  
  Select Case fieldType
  Case 2
    GetFieldType = "数値(整数)"
  Case 3
    GetFieldType = "数値(長整数)"
  Case 4
    GetFieldType = "数値(単精度浮動小数点)"
  Case 5
    GetFieldType = "数値(倍精度浮動小数点)"
  Case 6
    GetFieldType = "通貨"
  Case 7
    GetFieldType = "日付/時刻"
  Case 11
    GetFieldType = "Yes/No"
  Case 17
    GetFieldType = "数値(バイト)"
  Case 20
    GetFieldType = "大きい数値"
  Case 131
    GetFieldType = "数値(十進)"
  Case 202
    GetFieldType = "短いテキスト"
  Case 203
    GetFieldType = "長いテキスト(添付ファイル型の可能性有り)"
  Case 205
    GetFieldType = "OLE"
  Case Else
    GetFieldType = "その他"
  End Select

ReturnPoint:
  
  On Error Resume Next
  adoRs.Close
  adoCon.Close
  Set adoRs = Nothing
  Set adoCon = Nothing
  On Error GoTo 0
  
  Exit Function
  
ErrorHandler:
  MsgBox "テーブル・クエリのOpenに失敗しました。テーブル名・クエリ名が間違っているか、添付ファイル型のフィールドがあるクエリを指定した可能性があります"
  Resume ReturnPoint

ErrorHandler2:
  MsgBox "フィールドのデータ型の取得に失敗しました。フィールド名が間違っている可能性があります"
  Resume ReturnPoint
  
End Function
```
### ADOでクエリのデータを取得する
```
※基本的にテーブルと同じだが、添付ファイル型のフィールドを選択しているクエリは、Open時にエラーになってしまうらしい
Sub Sample2()
'クエリのデータをADOで取得する
'基本的にはテーブルと同じだが、添付ファイル型のフィールドを選択しているクエリはOpen時にエラーになるらしい

  Dim adoCon As ADODB.Connection
  Dim adoRs As ADODB.Recordset
  Dim path As String
  Dim queryName As String
  Dim i As Long
  
  path = "C:\work\テスト.accdb"
  tableName = "Qselect_全データ型2"
  '「Qselect_全データ型2」クエリは、「全データ型」テーブルの添付ファイル型フィールドを選択していない
  
  'tableName = "Qselect_全データ型"
  '「Qselect_全データ型」クエリは、「全データ型」テーブルの添付ファイル型フィールドを選択しているのでOpen時にエラーになる

  Set adoCon = New ADODB.Connection
  adoCon.ConnectionString = "provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & path & ";"
  adoCon.Open

  Set adoRs = New ADODB.Recordset
  With adoRs
    .Source = tableName
    .ActiveConnection = adoCon
    .Open
  End With
  
  For i = 0 To adoRs.Fields.Count - 1
    Debug.Print "フィールド名: " & adoRs.Fields(i).Name & "   TYPE: " & adoRs.Fields(i).Type
  Next i

  adoRs.Close
  adoCon.Close
  Set adoRs = Nothing
  Set adoCon = Nothing

End Sub
```
### 	SQLのLIKE句に関する注意点
```
DAOでは LIKE '*a*' で、 ADOでは LIKE '%a%' にする？
ACCESSのSQLや、ACCESSのVBAコード内のSQLなら、LIKE '*a*'  で"a"を含む文字列にヒットするが、
ExcelのVBAからACCESSを操作する場合、LIKE '%a%' と LIKE '*a*' を使い分けする必要があるらしい

DAO :    LIKE '*a*' とすれば"a"を含む文字列にヒットする
ADO :    LIKE '%a%' とすれば"a"を含む文字列にヒットする

"%" そのものを指定したい場合は、[%]としてエスケープで
DAO :    LIKE '*[%]*' とすれば"%"を含む文字列にヒットする
ADO :    LIKE '%[%]%' とすれば"%"を含む文字列にヒットする
```
### ADOを使用した場合の、SQL文内での特殊文字のエスケープ
```
DAOは違った結果になるかも　　　ACCESSのSQLや、ACCESSのVBAコード内のSQLと性質が違うようなので注意
ADOを使用した場合の、SQL文内での特殊文字のエスケープ。DAOは違った結果になるかも
ACCESSのSQLや、ACCESSのVBAコード内のSQLと性質が違うようなので注意
[]で囲むとエスケープされるらしい


"SELECT * FROM 文字列 WHERE 短いテキスト LIKE '%[%]%'"　　  %を含む文字列にヒット
"SELECT * FROM 文字列 WHERE 短いテキスト LIKE '%[""]%'"　　  "を含む文字列にヒット。2つ重ねること
"SELECT * FROM 文字列 WHERE 短いテキスト LIKE '%['']%'"　　  'を含む文字列にヒット。2つ重ねること
"SELECT * FROM 文字列 WHERE 短いテキスト LIKE '%[[]%'"　　  [を含む文字列にヒット
"SELECT * FROM 文字列 WHERE 短いテキスト LIKE '%[]]%'"　　  ]を含む文字列にヒット


' [ ] の3つは、検索は可能だがなるべく除外したほうがいいだろう
```
### ADOでのSQLで、大文字・小文字、半角･全角、ひらがな・カタカナを区別するバイナリモードを利用する
```
単純にOption Compare Binaryと宣言しても駄目らしい
**************  バイナリモードで文字列比較  **********************************

Option Compare Binary 'バイナリモードで文字列比較。この宣言が無くてもデフォルトでこの設定
Option Explicit

Sub aaa()

  Debug.Print "AAA" = "aaa"     'False   大文字･小文字を区別するので
  Debug.Print "AAA" Like "*a*"  'False

End Sub



**************  テキストモードで文字列比較  **********************************

Option Compare Text 'テキストモードで文字列比較
Option Explicit

Sub bbb()

  Debug.Print "AAA" = "aaa"     'True   大文字･小文字を区別しないので
  Debug.Print "AAA" Like "*a*"  'True

End Sub



**************  VBAコード内でのSQL   **********************************

Sub Sample1()
'Option Compare Binary宣言をしても、VBAコード内のSQLでは大文字・小文字が区別されないらしい
'InStr関数等を使用すれば、バイナリ比較が可能

  Dim adoCon As Object
  Dim adoRs As Object
  Dim path As String
  Dim sqlStr As String
  Dim str1 As String
  
  str1 = "a"  '検索する文字列

  path = "C:\work\テスト.accdb"

  Set adoCon = CreateObject("ADODB.Connection")
  adoCon.ConnectionString = "provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & path & ";"
  adoCon.Open

  Set adoRs = CreateObject("ADODB.Recordset") 'ADOレコードセットオブジェクトを作成
  

  sqlStr = "SELECT * FROM 文字列 WHERE 短いテキスト LIKE '%" & str1 & "%'"
  'VBAコード内では、LIKE句は*ではなく%を使う
  'これは大文字・小文字、半角・全角、ひらがな・カタカナが区別されない
  
  
  sqlStr = "SELECT * FROM 文字列 WHERE StrComp([短いテキスト], '" & str1 & "', 0) = 0"
  '上のコードだと、バイナリモードで完全一致( = ) の結果が得られる
  '大文字・小文字、半角・全角、ひらがな・カタカナが区別される
  
'    sqlStr = "SELECT * FROM 文字列 WHERE InStr(1, [短いテキスト], '" & str1 & "', 0)>0"
  'これは部分一致  LIKE '%a%'
  
'  sqlStr = "SELECT * FROM 文字列 WHERE InStr(1, [短いテキスト], '" & str1 & "', 0) = 1"
  'これは前方一致  LIKE 'a%'
  
'  sqlStr = "SELECT * FROM 文字列 WHERE StrComp(Right([短いテキスト],Len('" & str1 & "')),'" & str1 & "',0)=0"
  'これは後方一致  LIKE '%a'
  
  Cells.Clear
  
  adoRs.Open sqlStr, adoCon
  Cells(1, 1).CopyFromRecordset adoRs
  
  On Error Resume Next
  adoRs.Close
  adoCon.Close
  Set adoRs = Nothing
  Set adoCon = Nothing
  On Error GoTo 0

End Sub
```