ACCESSのテーブルにdbfをリンクするモジュールです。
ACCESS 2010 で成功しました。
標準モジュールにコピペして貼り付けて下さい。
パラメータの設定例は次の通り
① DBFが置いてあるフォルダ名 L:¥・・・など
② DBF名 たとえば"SetCurent,storename,User,Sales"・・・など
③ 0:リンク、1=インポート
これ以下、モジュール文
Option Compare Database
Option Explicit
'******************************************************************************
'テーブルをリンクし直す
' 引値1 DBFがあるフォルダ名
' 引値2 DBF名（カンマ区切り）複数設定できる、拡張子.DBFは不要
' 引値3 0:リンク、か、1=インポート
'******************************************************************************
Function procDBFLink(strDBFFolder As String, strTblList As String, intAcType As Integer)
On Error GoTo 0
'On Error GoTo Error_Trap
'**********************************************************
'変数定義
'**********************************************************
Dim dbsMDB As DAO.Database 'リンク中のテーブル
Dim strNowLinkName As String '現在のテーブルのリンク先
Dim strTBLArray() As String 'tblテーブル名配列
Dim strTBLName As String 'tblテーブル名個々
Dim strDBFName As String 'DBF名
Dim strDBFFullPass As String 'DBFのフルパス名
Dim lngArraySize As Long '配列サイズ0～n
Dim intIX As Integer '添え字
Dim blnReturn As Boolean '関数戻り値
'**********************************************************
'Table名確認
'**********************************************************
lngArraySize = 0
On Error Resume Next '配列に何もないとエラーとなる
strTBLArray = Split(strTblList, ",")
lngArraySize = UBound(strTBLArray) 'DBF名の配列
If lngArraySize < 0 Then '配列数なしは-1
Call procMsgToEnd("DBF名が設定されていません。")
End If
On Error GoTo 0
'-----------------------------------------------------
'DBFフォルダ名チェック
'-----------------------------------------------------
If Right(strDBFFolder, 1) <> "¥" Then
strDBFFolder = strDBFFolder & "¥"
End If
'存在チェック
'-----------------------------------------------------
'リンクタイプ、指定外設定はリンク
'-----------------------------------------------------
If intAcType > 1 Then
intAcType = 0 '0:リンク
End If
'**********************************************************
'テーブルをリンクする
'**********************************************************
On Error Resume Next 'テーブルが無ければエラーが出る
Set dbsMDB = CurrentDb
For intIX = 0 To lngArraySize
strTBLName = strTBLArray(intIX) 'テーブル名称
strDBFName = strTBLName & ".dbf" 'XXXX.dbf
strDBFFullPass = strDBFFolder & strDBFName 'Z:\YYYYY\XXXX.dbf
'----------------------
'DBFの存在チェック
'----------------------
blnReturn = procCheckFile(strDBFFullPass)
If blnReturn = False Then
MsgBox (strDBFFullPass & " が存在しません。")
Else
'----------------------
'現在のリンクテーブル名
'----------------------
strNowLinkName = procGetLinkDBFName(strTBLName)
'----------------------
'現在のリンクテーブル名と新テーブルを比較
'----------------------
If strNowLinkName <> strTBLName Then
dbsMDB.TableDefs.Refresh '一旦削除してから新規にリンク
On Error Resume Next 'テーブルが無ければエラーが出る
dbsMDB.TableDefs.Delete strTBLName 'テーブルを一旦削除する
If intAcType = 0 Then '0:リンク 1:インポート
DoCmd.TransferDatabase acLink, "dBase III", strDBFFolder, acTable, strDBFName, strTBLName, False
Else
DoCmd.TransferDatabase acImport, "dBase III", strDBFFolder, acTable, strDBFName, strTBLName, False
End If
dbsMDB.TableDefs.Refresh 'リンク再設定
End If
End If
Next
'------------------------------------
'DAOを閉じる
'------------------------------------
dbsMDB.Close
Set dbsMDB = Nothing
'**********************************************************
'終了処理
'**********************************************************
Exit_Procedure:
DoEvents
Exit Function
Error_Trap:
MsgBox ("[procTableLink]=" & Err.Description)
Application.Quit
Resume Exit_Procedure
End Function
'******************************************************************************
'テーブルのリンク先を調べる
'******************************************************************************
Function procGetLinkDBFName(varTableName As Variant) As String
On Error Resume Next 'テーブルが無ければエラーが出る
Dim dbsDB As DAO.Database
Dim tblTable As DAO.TableDef
Dim blnReturn As Boolean
Set dbsDB = CurrentDb
dbsDB.TableDefs.Refresh
blnReturn = 0
For Each tblTable In dbsDB.TableDefs
If tblTable.Name = varTableName Then
If Len(tblTable.Connect) = 0 Then
Else
procGetLinkDBFName = Mid(tblTable.Connect, InStr(1, tblTable.Connect, "DATABASE=", vbTextCompare) + 9)
End If
blnReturn = True
Exit For
End If
Next
dbsDB.Close
Set dbsDB = Nothing
End Function
