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

「他の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_テスト１"
CopyTables(1) = "T_テスト２"
CopyTables(2) = "T_テスト３"
CopyTables(3) = "T_テスト４"

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