Mam's WebSite
建築CGパース住宅CGパース

Mamの覚書Q&A検索

トップページMamの覚書Q&A検索Access(VBA)⇒Q&A


大項目:「 Access 」 - 中項目:「 VBA 」

「 他のMDBファイルからテーブルをコピーするには 」

他のMDBファイルのテーブルを現在のMDBファイルにコピーしたいのですが、
どうすればよいでしょうか。


回答

以下のコードで可能です。
以下のコードではコピーする前に、現在のMDBファイルにテーブルがあるか調べて、
あれば削除しています。

ソース

Option Compare Database
Option Explicit
 
'削除してからコピーするテーブル名の配列
Dim CopyTables() As String
 

Sub BatchCopy()
On Error GoTo err_BatchCopy
Dim FromFile As String  '取り込み元ファイル名
Dim i As Integer
Dim MyFile As String
Dim MyDB As Database
Dim AccApp As Access.Application
 
'ファイルを選択
FromFile = SelectFile()
 

If FromFile = "" Then
'キャンセルの場合
  Exit Sub
ElseIf FromFile = Application.CurrentDb.Name Then
'このファイル自身を選んでしまった場合
  MsgBox ("このファイル自体を選んでいます")
  Exit Sub
ElseIf Dir(FromFile) = "" Then
'存在しないファイルを選択した場合
  MsgBox ("ファイルが存在しません")
  Exit Sub
End If
 
Application.DoCmd.SetWarnings False
Screen.MousePointer = 11
 

'コピーするテーブル名の配列再定義
ReDim CopyTables(3) As String
CopyTables(0) = "T_テスト1"
CopyTables(1) = "T_テスト2"
CopyTables(2) = "T_テスト3"
CopyTables(3) = "T_テスト4"
 

 
Set MyDB = CurrentDb()
MyFile = MyDB.Name
 

'指定したテーブルを削除する
For i = LBound(CopyTables, 1) To UBound(CopyTables, 1)
  If table_Exists(CopyTables(i), MyDB) Then
    Application.DoCmd.DeleteObject acTable, CopyTables(i)
  End If
Next i
 
'新規のアプリケーションオブジェクトを作成
Set AccApp = New Access.Application
'新規のアプリケーションオブジェクトのカレントデータベースを設定して開く
AccApp.OpenCurrentDatabase FromFile
 
'選択ファイルのデータベースからこのファイルにテーブルをコピー
For i = LBound(CopyTables, 1) To UBound(CopyTables, 1)
  AccApp.DoCmd.CopyObject MyFile, CopyTables(i), acTable, CopyTables(i)
Next i
 
'新規のアプリケーションのデータベースを閉じる
AccApp.CloseCurrentDatabase
AccApp.Quit
Set AccApp = Nothing
 

Application.DoCmd.SetWarnings True
 
MyDB.tabledefs.Refresh
Set MyDB = Nothing
 
'5000ミリ秒待つ(Access97では待たないとなぜかテーブルコピーが完了していない)
Sleep (5000)
 
'データベースウィンドウを更新するために一旦Queryに切り替えてから、
'Tableに切り替える。テストのときのみ以下を有効にする
'Application.DoCmd.SelectObject acQuery, , True
'Application.DoCmd.SelectObject acTable, , True
 

 
Application.DoCmd.SetWarnings True
Screen.MousePointer = 0
 
Exit Sub
 
err_BatchCopy:
  Application.DoCmd.SetWarnings True
  Screen.MousePointer = 0
  MsgBox "Error number " & Err.Number & " : " & Err.Description
Exit Sub
 

End Sub
 
'テーブルが存在するか調べる
Function table_Exists(A As String, db As Database) As Boolean
    Dim i As Integer
    Dim c As Integer
    Dim flag As Boolean
    
    flag = False
    c = db.tabledefs.Count
    For i = 0 To c - 1
        If db.tabledefs(i).Name = A Then flag = True
    Next i
    table_Exists = flag
End Function


Mam's WebSite