以下は、動作保証をしないので、自己責任で確認のこと。プログラム等その他により生じたいかなる損害等その他について、責任を負いませんので、予めご了承してください。

【オートナンバーの初期化】

（対象テーブル）

テーブル名：テーブル1

フィールド名：フィールド1

（オートナンバーの初期化手順）

INSERT INTO テーブル1 ( ID ) SELECT 0 AS A;

DELETE * FROM テーブル1;

[使用例]

DoCmd.SetWarnings False

DoCmd.Close acTable, "テーブル1"

DoCmd.RunSQL "INSERT INTO テーブル1 ( ID ) SELECT 0 AS A; "

DoCmd.RunSQL "DELETE * FROM テーブル1;"

DoCmd.SetWarnings True

【Docmd関係】

①DLookup(取得する値のあるフィールド,テーブル名，抽出条件）

例

if Application.DLookup("フィールド1","テーブル1"，"ID = 3"）= 2 then

end if

【情報の取得】

Option Compare Database

Sub 情報の取得()

'version

Debug.Print Application.CurrentDb.Containers("Databases").Documents("UserDefined").Properties("Version").Value

'接続方法

Debug.Print Application.CurrentProject.AccessConnection.ConnectionString

End Sub

【ADO ACCESS】

Option Compare Database

Option Explicit

'Const adOpenDynamic As Byte = 2

'Const adLockOptimistic As Byte = 3

'Const adCmdTable As Byte = 2

Private Sub ADO_ACCESS()

'Microsoft ActiveX Data Objects 6.1 Library

Dim mCn As ADODB.Connection

Dim mRs As ADODB.Recordset

Set mCn = New ADODB.Connection

' 接続文字列を設定

'mCn.ConnectionString = _

' "Provider=Microsoft.Jet.OLEDB.3.51;" & _

' "Data Source=..\Db\NWIND.MDB"

mCn.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;" & _

"Data Source=" & Application.CurrentProject.Path & "\Database1.accdb" & ";Persist Security Info=True"

' コネクションをオープン

mCn.Open

Set mRs = New ADODB.Recordset

' Call ADO_Execute(mCn, mRs)

' Call ADO_Recordset_ADD(mCn, mRs)

Call ADO_Recordset_Read(mCn, mRs)

' オブジェクトを解放

On Error Resume Next

If Not (mRs Is Nothing) Then

Set mRs = Nothing

End If

If Not (mCn Is Nothing) Then

On Error Resume Next

mCn.Close

Set mCn = Nothing

End If

End Sub

Private Sub ADO_Execute(ByVal mCn As ADODB.Connection, ByVal mRs As ADODB.Recordset)

' レコードセットをオープン

Set mRs = mCn.Execute("Select * From テーブル1;")

' 取得したデータを表示

Debug.Print mRs.Fields("ID")

Debug.Print mRs.Fields("Data1")

Debug.Print mRs.Fields("Data2")

' オブジェクトを閉じる

mRs.Close

End Sub

Private Sub ADO_Recordset_Read(ByVal mCn As ADODB.Connection, ByVal mRs As ADODB.Recordset)

' レコードセットOpen テーブル

Dim SQL As String

SQL = "SELECT [テーブル1].ID, [テーブル1].Data1, [テーブル1].Data2 FROM テーブル1;"

'mRs.Open "テーブル1", mCn, adOpenDynamic, adLockOptimistic, adCmdTable'テーブル名を使用するとき

mRs.Open SQL, mCn, adOpenDynamic, adLockOptimistic

If Not mRs.EOF Then

mRs.MoveFirst

End If

' 取得したデータを表示

Debug.Print mRs.Fields("ID")

Debug.Print mRs.Fields("Data1")

Debug.Print mRs.Fields("Data2")

' オブジェクトを閉じる

mRs.Close

End Sub

Private Sub ADO_Recordset_ADD(ByVal mCn As ADODB.Connection, ByVal mRs As ADODB.Recordset)

' レコードセットOpen テーブル

Dim SQL As String

SQL = "SELECT [テーブル1].ID, [テーブル1].Data1, [テーブル1].Data2 FROM テーブル1;"

'mRs.Open "テーブル1", mCn, adOpenDynamic, adLockOptimistic, adCmdTable'テーブル名を使用するとき

mRs.Open SQL, mCn, adOpenDynamic, adLockOptimistic

If Not mRs.EOF Then

mRs.MoveFirst

End If

mRs.AddNew '新規追加

mRs.Fields(1).Value = "い"

mRs.Fields(2).Value = "2"

mRs.Update '更新

' オブジェクトを閉じる

mRs.Close

End Sub

Private Sub ADO_Catalog()

'ADOによるテーブルの作成 比較SQLによるテーブルの作成

'Microsoft ADO Ext.6.0 for DDl and Securityを参照

Dim ADOX_DB As ADOX.Catalog

Dim ADOX_Table As ADOX.Table

Dim ADOX_Index As ADOX.Index

Dim ADODB_Cmd As ADODB.Command

Dim sSQL As String

Const adVarWChar As Byte = 202

Set ADOX_DB = New ADOX.Catalog

On Error Resume Next

'Kill(My.Application.Info.DirectoryPath & "\CreatDB.mdb")

Kill Application.CurrentProject.Path & "\Database2.accdb"

On Error GoTo 0

ADOX_DB.Create "PROVIDER=Microsoft.ACE.OLEDB.12.0;" & _

"Data Source=" & Application.CurrentProject.Path & "\Database2.accdb"

'ADOX_DB.ActiveConnection = CurrentProject.Connection

Set ADOX_Table = New ADOX.Table

With ADOX_Table

.Name = "TEST1"

.Columns.Append "ID", adInteger

.Columns.Item("ID").Properties("AutoIncrement") = True

' .Columns.Append "field name(数値型）", adInteger '

'エクセルのフィールド名をアクセスのフィールド名にする処理

'.Columns.Append "Data1", adVarWChar, 50 '

.Columns.Append "Data1", adVarWChar

End With

ADOX_DB.Tables.Append ADOX_Table

Set ADOX_Index = New ADOX.Index

With ADOX_Index

.Name = "ID_Index"

.PrimaryKey = True

.Columns.Append "ID"

End With

ADOX_Table.Indexes.Append ADOX_Index

sSQL = "SELECT * FROM TEST1;"

Set ADODB_Cmd = New ADODB.Command

ADODB_Cmd.CommandText = sSQL

ADOX_DB.Views.Append "QTEST1", ADODB_Cmd

'ADOX_DB.Tables.Delete "TEST1"

'ADOX_Table.Indexes.Delete "ID_Index"

Set ADODB_Cmd = Nothing

Set ADOX_Index = Nothing

Set ADOX_Table = Nothing

Set ADOX_DB = Nothing

End Sub

【ADO EXCEL】

Option Compare Database

Option Explicit

Private Sub ADO_EXCEL()

'Microsoft ActiveX Data Objects 6.1 Library

Dim mCn As ADODB.Connection

Dim mRs As ADODB.Recordset

Set mCn = New ADODB.Connection

'Excelデータ接続

'' 接続文字列を設定します。

'"Data Source=" & "C:\BookDB.xls;" & _

'"Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties=Excel 8.0;"

mCn.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;" & _

"Data Source=" & Application.CurrentProject.Path & "\BookDB.xlsx" & ";Extended Properties=Excel 12.0;"

' コネクションをオープン

mCn.Open

Set mRs = New ADODB.Recordset

'Call ADO_EXCEL_Execute(mCn, mRs)

'ADO_EXCEL_Recordset_Update

Call ADO_EXCEL_Recordset_Read(mCn, mRs)

' オブジェクトを解放

On Error Resume Next

If Not (mRs Is Nothing) Then

Set mRs = Nothing

End If

If Not (mCn Is Nothing) Then

On Error Resume Next

mCn.Close

Set mCn = Nothing

End If

End Sub

Private Sub ADO_EXCEL_Recordset_Read(ByVal mCn As ADODB.Connection, ByVal mRs As ADODB.Recordset)

' レコードセットOpen テーブル

Dim SQL As String

SQL = "SELECT * from [Sheet1$]" '[Sheet1$A1:E24]

mRs.Open SQL, mCn, adOpenDynamic, adLockOptimistic

If Not mRs.EOF Then

mRs.MoveFirst

End If

' 取得したデータを表示

Debug.Print mRs.Fields(0)

Debug.Print mRs.Fields(1)

Debug.Print mRs.Fields(2)

' オブジェクトを閉じる

mRs.Close

End Sub

Private Sub ADO_EXCEL_Recordset_Update(ByVal mCn As ADODB.Connection, ByVal mRs As ADODB.Recordset)

' レコードセットOpen テーブル

Dim SQL As String

SQL = "SELECT * from [Sheet1$]" '[Sheet1$A1:E24]

mRs.Open SQL, mCn, adOpenDynamic, adLockOptimistic

If Not mRs.EOF Then

mRs.MoveFirst

End If

mRs.AddNew '新規追加

mRs.Fields(0).Value = "4"

mRs.Fields(1).Value = "い"

mRs.Fields(2).Value = "2"

mRs.Update '更新

' オブジェクトを閉じる

mRs.Close

End Sub

【DAO ACCESS CSV EXCEL】

Option Compare Database

Option Explicit

Sub DAO_ACCESS()

'Declare variables.

Dim ojcdb As DAO.Database

Dim ojcrs As DAO.Recordset

Dim mySQL As String

Dim wrkDefault As DAO.Workspace

'Set wrkDefault = DBEngine.Workspaces(0)

'Set wrkDefault = Me.Application.DBEngine.Workspaces(0)

Set wrkDefault = Application.CurrentProject.Properties.Application.DBEngine.Workspaces(0)

'BeginTrans、CommitTrans、Rollback メソッドの使用例

' 既定の Workspace を取得します。

Set ojcdb = CurrentDb()

mySQL = "SELECT * FROM テーブル1;"

Set ojcrs = ojcdb.OpenRecordset(mySQL)

On Error GoTo err_esc

If Not (ojcrs.EOF Or ojcrs.BOF) Then

ojcrs.MoveLast

Debug.Print ojcrs.RecordCount

Else

Debug.Print 1

End If

err_esc:

On Error Resume Next

If Not (ojcrs Is Nothing) Then

On Error Resume Next

ojcrs.Close

Set ojcrs = Nothing

End If

If Not (ojcdb Is Nothing) Then

On Error Resume Next

ojcdb.Close

Set ojcdb = Nothing

End If

End Sub

Private Sub DAO_CSV()

Dim ws As DAO.Workspace

Dim db As DAO.Database

Dim rs As DAO.Recordset

Dim sPath As String

Dim sSQL As String

Const CSV_OPEN_OPTION = "TEXT;HDR=NO;FMT=Delimited" 'FMT=DelimitedでCSV

sPath = Application.CurrentProject.Path & "\test\test1.csv"

Set ws = DBEngine.Workspaces(0)

Set db = ws.OpenDatabase(Application.CurrentProject.Path, False, False, CSV_OPEN_OPTION)

sSQL = "Select * FROM test1.csv"

Set rs = db.OpenRecordset(sSQL, dbOpenDynaset)

Do Until rs.EOF

Debug.Print rs(0).Value & "," & rs(1).Value & "," & rs(2).Value

rs.MoveNext

Loop

rs.Close

db.Close

ws.Close

Set rs = Nothing

Set db = Nothing

Set ws = Nothing

End Sub

Private Sub DAO_EXCEL()

Dim ws As DAO.Workspace

Dim db As DAO.Database

Dim rs As DAO.Recordset

Dim sPath As String

Dim sSQL As String

Const EXCEL_OPEN_OPTION = "EXCEL 8.0;HDR=YES;"

sPath = Application.CurrentProject.Path & "\BookDB.xlsx"

Set ws = DBEngine.Workspaces(0)

Set db = ws.OpenDatabase(sPath, False, False, EXCEL_OPEN_OPTION)

sSQL = "SELECT * from [Sheet1$]" '[Sheet1$A1:E24]

Set rs = db.OpenRecordset(sSQL, dbOpenDynaset)

Do Until rs.EOF

Debug.Print rs(0).Value & "," & rs(1).Value & "," & rs(2).Value

rs.MoveNext

Loop

rs.Close

db.Close

ws.Close

Set rs = Nothing

Set db = Nothing

Set ws = Nothing

End Sub

【最適化】

Microsoftのサイトの「Compact Access-DB nur mit VBNet」及び「DBEngine.CompactDatabaseメソッド（DAO）」等その他のHelpファイルを使いやすくメモ。マイクロソフトのアドレスはそのうち変化してしまうため、注意が必要。

Option Compare Database

Option Explicit

Private Sub ACCESS_CompactDatabase_mdb()

'外部参照

'Microsoft Jet and Replication Objects 2.6 Library

'C:\Program Files(x86)\Common Files\System\ado\msjro.dll

Dim strOldConnection As String

Dim strNewConnection As String

Dim objJroJetEngine As JRO.JetEngine

Set objJroJetEngine = New JRO.JetEngine

' 接続文字列を設定

strOldConnection = _

"Provider=Microsoft.Jet.OLEDB.4.0;" & _

"Data Source=" & Application.CurrentProject.Path & "\Database1.mdb"

strNewConnection = _

"Provider=Microsoft.Jet.OLEDB.4.0;" & _

"Data Source=" & Application.CurrentProject.Path & "\Database2.mdb"

' データベースの最適化

objJroJetEngine.CompactDatabase _

strOldConnection, _

strNewConnection

' オブジェクトを解放

Set objJroJetEngine = Nothing

End Sub

Private Sub ACCESS_CompactDatabase_accdb()

Dim strSourcePath As String

Dim strDestPath As String

strSourcePath = Application.CurrentProject.Path & "\Database1.accdb"

strDestPath = Application.CurrentProject.Path & "\Database2.accdb"

'デフォルトパスワード（暗号キー）：Access accdbは１つなので、２つのpwdは同じものを設定

DBEngine.CompactDatabase strSourcePath, strDestPath, dbLangGeneral & ";pwd=Access", dbVersion120, ";pwd=Access"

MsgBox "Finished"

End Sub

【参照設定の自動設定＆自動解除】

主にReferences オブジェクト (Access) の使いやすいメモ

マイクロソフトのアドレスはそのうち変化してしまうため、注意が必要。

以下は参考資料扱い。個人保有の商業使用可能なVisual Studioプロフェッショナル等その他のライセンスによるメモという感じで私的使用目的です。ほとんどはヘルプファイルそのもの的なものですが、使いやすいようにした部分とプログラム中の参照設定の設定パスや文字列などは、個人的なWindows10の開発環境によるので、ヘルプファイルそのものではないことに注意が必要。

［クラス名：refevents］

Option Compare Database

Option Explicit

' Declare object variable to represent References collection.

Public WithEvents evtReferences As References

' When instance of class is created, initialize evtReferences

' variable.

Private Sub Class_Initialize()

Set evtReferences = Application.References

End Sub

' When instance is removed, set evtReferences to Nothing.

Private Sub Class_Terminate()

Set evtReferences = Nothing

End Sub

' Display message when reference is added.

Private Sub evtReferences_ItemAdded(ByVal Reference As _

Access.Reference)

' MsgBox "Reference to " & Reference.Name & " added."

End Sub

' Display message when reference is removed.

Private Sub evtReferences_ItemRemoved(ByVal Reference As _

Access.Reference)

' MsgBox "Reference to " & Reference.Name & " removed."

End Sub

［モジュール名：MReference］

Option Compare Database

Option Explicit

' Create new instance of RefEvents class.

Dim objRefEvents As New refevents

Public Sub Reference_NameandFullPath_Chack()

Dim RefItem As Reference

For Each RefItem In Application.References

If RefItem.IsBroken = False Then

Debug.Print "[Name]" & RefItem.Name & ":[FullPath]" & RefItem.FullPath

End If

Next

End Sub

Public Sub Reference_Add()

Call AddReference("C:\PROGRAM FILES\COMMON FILES\SYSTEM\ADO\msado15.dll")

End Sub

Public Sub Reference_Remove()

Call RemoveReference("ADODB")

End Sub

' Pass file name and path of type library to this procedure.

Function AddReference(strFileName As String) As Boolean

Dim ref As Reference

On Error GoTo Error_AddReference

' Create new reference on References object variable.

Set ref = objRefEvents.evtReferences.AddFromFile(strFileName)

AddReference = True

Exit_AddReference:

Exit Function

Error_AddReference:

MsgBox Err & ": " & Err.Description

AddReference = False

Resume Exit_AddReference

End Function

Function RemoveReference(strRefName As String) As Boolean

Dim ref As Reference

On Error GoTo Error_RemoveReference

' Return object representing existing reference.

Set ref = objRefEvents.evtReferences(strRefName)

' Remove reference from collection.

objRefEvents.evtReferences.Remove ref

RemoveReference = True

Exit_RemoveReference:

Exit Function

Error_RemoveReference:

MsgBox Err & ": " & Err.Description

RemoveReference = False

Resume Exit_RemoveReference

End Function

©Hirotoshi Takano