VBA:MS-Access(DAO)テンプレート

ExcelからMS-Accessのデータを簡易取り出し。

dbPath = "xxx.accdb"
Set dbe = CreateObject("DAO.DBEngine.120")
Set Db = dbe.Workspaces(0).OpenDatabase(dbPath, False)

Sql = "select x from xxxx where xx ="x"
Set dbRes = Db.OpenRecordset(Sql)
wkCMT = dbRes("x").Value

dbRes.Close
Db.Close
Set Db = Nothing
Set dbe = Nothing

 

MS-Access 削除クエリ対処

削除クエリ実行時(2つのテーブルをリンク)に下記のエラーが出るときがある。
「指定されたテーブルから削除できませんでした。」

対象のクエリ編集画面にてF4を押す。
[固有のレコード] を [はい]に変更。
これで解決できる。

MDBのテーブルリンクを自動リフレッシュ

Sub MDB_TABLE_REFRESH()
    re_link_table "M_AGENT"
    re_link_table "M_FA_LOCATION"
    re_link_table "M_STATUS"
    re_link_table "T_COMMNET"
    re_link_table "T_REQUEST"
End Sub

Sub re_link_table(tbl_name As String)
    Dim dbs As Database
    Dim tdf As TableDef

    Set dbs = CurrentDb
    Set tdf = dbs.TableDefs(tbl_name)
    With tdf
      .Connect = ";DATABASE=\\xxxxxxx\zzz.accdb;TABLE=" & tbl_name
      .RefreshLink
    End With
End Sub

MDBの最適化

スクリプトでMDB(閉じている)の最適化を行う。

'一時ファイルは、オリジナルファイル名にtmpを付与した名前
'処理後にオリジナルを削除して、一時ファイルをオリジナルに置き換える
sTmp = "xxxxxxx.accdb"
DBEngine.CompactDatabase sTmp, sTmp & "tmp"
Kill sTmp
Name sTmp & "tmp" As sTmp

ODBC linkリフレッシュ

Private Sub btnGO_Click()
	
	Dim wkTBL As String, wkLEN As String, wkDSN As String
	Dim WKSRCTBL As String, wkUID
	Dim MyTbl As DAO.TableDef
	Dim prp As DAO.Property
	
	For Each MyTbl In CurrentDb.TableDefs
		wkTBL = MyTbl.Name
		WKSRCTBL = MyTbl.SourceTableName
		If MyTbl.Attributes And dbAttachedODBC Then
			wkLEN = InStr(1, MyTbl.Connect, “DSN=") + 4
			wkDSN = Mid(MyTbl.Connect, wkLEN, InStr(wkLEN, MyTbl.Connect, “;") – wkLEN)
			'call link
			AUTO_LINK wkTBL, WKSRCTBL, wkDSN, “userid", “password"
			End If
		End If
	Next
	
	MsgBox “done!"
	Exit Sub
End Sub

Sub AUTO_LINK(dbtable As String, dbname As String, dsn As String, uid As String, pwd As String)
	
	Dim db As Database, TblDef As TableDef
	Dim prp As DAO.Property, flgpw As Boolean
	
	flgpw = True 'save password in link
	On Error Resume Next
	'delete
	DoCmd.DeleteObject acTable, dbtable
	On Error GoTo 0
	Set db = DBEngine.Workspaces(0).Databases(0)
	
	Set TblDef = db.CreateTableDef(dbtable)
	TblDef.Connect = “ODBC;DSN=" & dsn & “;UID=" & uid & “;PWD=" & pwd
	TblDef.SourceTableName = dbname
	If flgpw Then
		TblDef.Attributes = dbAttachSavePWD
	End If
	
	db.TableDefs.Append TblDef
	
	Set prp = TblDef.CreateProperty(“Description", dbText, dsn & “:" & uid)
	TblDef.Properties.Append prp
	TblDef.Properties.Refresh
	TblDef.RefreshLink
End Sub

クエリ内容をテキストSQLよりインポート

Private Sub btnGO_Click()
	
	Dim wkTBL As String, wkLEN As String, wkDSN As String
	Dim WKSRCTBL As String, wkUID
	Dim MyTbl As DAO.TableDef
	Dim prp As DAO.Property
	
	For Each MyTbl In CurrentDb.TableDefs
		wkTBL = MyTbl.Name
		WKSRCTBL = MyTbl.SourceTableName
		If MyTbl.Attributes And dbAttachedODBC Then
			wkLEN = InStr(1, MyTbl.Connect, “DSN=") + 4
			wkDSN = Mid(MyTbl.Connect, wkLEN, InStr(wkLEN, MyTbl.Connect, “;") – wkLEN)
			'call link
			AUTO_LINK wkTBL, WKSRCTBL, wkDSN, “userid", “password"
			End If
		End If
	Next
	
	MsgBox “done!"
	Exit Sub
End Sub

Sub AUTO_LINK(dbtable As String, dbname As String, dsn As String, uid As String, pwd As String)
	
	Dim db As Database, TblDef As TableDef
	Dim prp As DAO.Property, flgpw As Boolean
	
	flgpw = True 'save password in link
	On Error Resume Next
	'delete
	DoCmd.DeleteObject acTable, dbtable
	On Error GoTo 0
	Set db = DBEngine.Workspaces(0).Databases(0)
	
	Set TblDef = db.CreateTableDef(dbtable)
	TblDef.Connect = “ODBC;DSN=" & dsn & “;UID=" & uid & “;PWD=" & pwd
	TblDef.SourceTableName = dbname
	If flgpw Then
		TblDef.Attributes = dbAttachSavePWD
	End If
	
	db.TableDefs.Append TblDef
	
	Set prp = TblDef.CreateProperty(“Description", dbText, dsn & “:" & uid)
	TblDef.Properties.Append prp
	TblDef.Properties.Refresh
	TblDef.RefreshLink
End Sub

クエリ名とSQLをテキスト出力

Sub クエリをテキスト出力する()
	Dim dbs As Database
	Dim intCount As Integer
	Dim QDF As QueryDef
	
	Open “c:\temp\export_query.txt" For Output As #1
	Set dbs = CurrentDb
	
	For intCount = 0 To dbs.QueryDefs.Count – 1
		Set QDF = dbs.QueryDefs(intCount)
		Print #1, QDF.Name
		Print #1, QDF.SQL
		'Debug.Print QDF.SQL
	Next
	
	Close
End Sub

Export name of Query

Sub Sample()
	Dim mymydb  As Database
	
	Set mydb = CurrentDb
	
	Debug.Print "すべてのクエリ名を出力します"
	For Each myqer In mydb.QueryDefs
		Debug.Print myqer.Name
	Next
End Sub