アクセス2007 テーブルの全削除とデータ移動

質問

アクセス2007　テーブルの全削除とデータ移動

全テーブルを削除して、データをインポートしようとしています。
http://okwave.jp/qa/q5952603.html
以前の質問＜QNo.5952603＞の続きになってしまいますが。

>質問3.
>削除後にインポートをしたいのですが。
>手動でアクセスメニュー＞外部データ＞アクセス（のインポート）＞現在の～～＞すべて選択（テーブル）＞ＯＫ
>これを実現するＶＢの記述は、どんなコードになるのでしょうか？
答え
＞DoCmd.TransferDatabase acImport, "Microsoft Access", strPATH, acTable, strTDef, strTDef, False

なのですが、手動で行った場合の「オプション」＞インポート「リレーションシップ=チェックON」の部分が
上記のお答えのコードで実現できませんでした。

各クエリの部分的なリレーションは残ってますが、全体のリレーション線が消えてしまいます。
どのようにしたら再現できますでしょうか？

回答No.1

piroin654 · ベストアンサー

急激な暑さで文章の読解力が落ちている
この頃です。

(1)
以下msのsupportを利用しています。
フォームモジュールのどこかにこのまま張り付けてください。

Private Sub ImportRelations2(DBName As String)
Dim ThisDb As Database, ThatDB As Database
Dim ThisRela As Relation, ThatRela As Relation
Dim ThisField As Field, ThatField As Field
Dim cnt As Integer, RCount As Integer
Dim i As Integer, j As Integer
Dim ErrBadField As Integer

RCount = 0
Set ThisDb = CurrentDb
Set ThatDB = DBEngine.Workspaces(0).OpenDatabase(DBName)

For i = 0 To ThatDB.Relations.Count - 1
Set ThatRela = ThatDB.Relations(i)

Set ThisRela = ThisDb.CreateRelation(ThatRela.Name, _
ThatRela.Table, ThatRela.ForeignTable, _
ThatRela.Attributes)
ErrBadField = False

On Error Resume Next
For j = 0 To ThatRela.Fields.Count - 1
Set ThatField = ThatRela.Fields(j)

Set ThisField = ThisRela.CreateField(ThatField.Name)
ThisField.ForeignName = ThatField.ForeignName
ThisRela.Fields.Append ThisField

If Err <> False Then ErrBadField = True
Next j
On Error GoTo 0
If ErrBadField = True Then

Else

On Error Resume Next
ThisDb.Relations.Append ThisRela
If Err <> False Then

Else
RCount = RCount + 1
End If
On Error GoTo 0
End If
Next i

ThisDb.Close
Set ThisDb = Nothing
ThatDB.Close
Set ThatDB = Nothing
End Sub

(2)
次にテーブルのインポートのプロシージャの下の部分に

Call ImportRelations(strPATH)

を加えます。

Next

'リレーションのインポート
Call ImportRelations(strPATH)

db.Close
Set db = Nothing
End Sub

このようにします。これで終了です。

お礼

piroin654様、いつも、いつもご丁寧に感謝致します。

ご回答のコードをそっくりそのまま、使わせて頂きました。
無事希望どうりの動作をしています。
私の技量では絶対無理な技で、ありがたく思っています。

今後も、宜しくお願い致します。
ありがとうございました。

回答No.2

piroin654

訂正です。プロシージャの先頭、

>Private Sub ImportRelations2(DBName As String)

を

Private Sub ImportRelations(DBName As String)

にしてください。いらないものがくっついていました。