Сохранение связанных таблиц для баз данных Access в той же папке при изменении папки
-
22-08-2019 - |
Вопрос
У меня есть две базы данных Access, которые имеют общие связанные таблицы.Они развертываются вместе в каталоге и доступны через код в форме Word.
Как я могу убедиться, что ссылки сохраняются, когда две базы данных копируются (вместе) в другую папку?Поскольку я не «открываю» базу данных как таковую (доступ к ней осуществляется через ADO), я не знаю, как написать код для обновления ссылок.
Решение
Обновление от 14 апреля 2009 г.Я обнаружил, что предыдущий ответ, который я дал здесь, был ошибочным, поэтому я обновил его, добавив новый код.
Как действовать
- Скопируйте приведенный ниже код в модуль VBA.
Из кода или из Немедленный окне в VBA IDE просто введите:
RefreshLinksToPath Application.CurrentProject.Path
Теперь все связанные таблицы будут перелинкованы для использования каталога, в котором находится ваше приложение.
Это нужно делать только один раз или при каждом повторном связывании или добавлении новых таблиц.
Я рекомендую делать это из кода каждый раз, когда вы запускаете приложение.
После этого вы сможете без проблем перемещать свои базы данных.
Код
'------------------------------------------------------------'
' Reconnect all linked tables using the given path. '
' This only needs to be done once after the physical backend '
' has been moved to another location to correctly link to '
' the moved tables again. '
' If the OnlyForTablesMatching parameter is given, then '
' each table name is tested against the LIKE operator for a '
' possible match to this parameter. '
' Only matching tables would be changed. '
' For instance: '
' RefreshLinksToPath(CurrentProject.Path, "local*") '
' Would force all tables whose ane starts with 'local' to be '
' relinked to the current application directory. '
'------------------------------------------------------------'
Public Function RefreshLinksToPath(strNewPath As String, _
Optional OnlyForTablesMatching As String = "*") As Boolean
Dim collTbls As New Collection
Dim i As Integer
Dim strDBPath As String
Dim strTbl As String
Dim strMsg As String
Dim strDBName As String
Dim strcon As String
Dim dbCurr As DAO.Database
Dim dbLink As DAO.Database
Dim tdf As TableDef
Set dbCurr = CurrentDb
On Local Error GoTo fRefreshLinks_Err
'First get all linked tables in a collection'
dbCurr.TableDefs.Refresh
For Each tdf In dbCurr.TableDefs
With tdf
If ((.Attributes And TableDefAttributeEnum.dbAttachedTable) = TableDefAttributeEnum.dbAttachedTable) _
And (.Name Like OnlyForTablesMatching) Then
collTbls.Add Item:=.Name & .Connect, key:=.Name
End If
End With
Next
Set tdf = Nothing
' Now link all of them'
For i = collTbls.count To 1 Step -1
strcon = collTbls(i)
' Get the original name of the linked table '
strDBPath = Right(strcon, Len(strcon) - (InStr(1, strcon, "DATABASE=") + 8))
' Get table name from connection string '
strTbl = Left$(strcon, InStr(1, strcon, ";") - 1)
' Get the name of the linked database '
strDBName = Right(strDBPath, Len(strDBPath) - InStrRev(strDBPath, "\"))
' Reconstruct the full database path with the given path '
strDBPath = strNewPath & "\" & strDBName
' Reconnect '
Set tdf = dbCurr.TableDefs(strTbl)
With tdf
.Connect = ";Database=" & strDBPath
.RefreshLink
collTbls.Remove (.Name)
End With
Next
RefreshLinksToPath = True
fRefreshLinks_End:
Set collTbls = Nothing
Set tdf = Nothing
Set dbLink = Nothing
Set dbCurr = Nothing
Exit Function
fRefreshLinks_Err:
RefreshLinksToPath = False
Select Case Err
Case 3059:
Case Else:
strMsg = "Error Information..." & vbCrLf & vbCrLf
strMsg = strMsg & "Function: fRefreshLinks" & vbCrLf
strMsg = strMsg & "Description: " & Err.Description & vbCrLf
strMsg = strMsg & "Error #: " & Format$(Err.Number) & vbCrLf
MsgBox strMsg
Resume fRefreshLinks_End
End Select
End Function
Этот код адаптирован из этого источника: http://www.mvps.org/access/tables/tbl0009.htm.
Я удалил всю зависимость от других функций, чтобы сделать его самодостаточным, поэтому он немного длиннее, чем должен.
Другие советы
Вы имеете в виду обновление ссылок в вашей форме Word или связанных таблиц между вашими базами данных Access?
В первом случае лучший способ, который я знаю, — это сохранить строки подключения на уровне модуля в вашем документе Word/проекте VBA и сделать их константными строками.Затем при настройке строки подключения для объектов ADO Connection передайте ему относительную строку подключения const.
В последнем случае у меня возникнет соблазн использовать относительный путь в строке подключения к данным внутри каждой базы данных Access к другой.Например,
Dim connectionString as String
connectionString = ";DATABASE=" & CurrentProject.Path & "\[Database Name Here].mdb"
если, как вы говорите, базы копируются вместе в другую папку (я предполагая в ту же папку).
Ответ Рено больше не работает в Access 2010 с файлами Excel или CSV.
Я сделал несколько модификаций:
- Адаптировано к текущему шаблону строки подключения.
- Путь к базе данных обрабатывается по-разному для файлов Excel (включая имя файла) и файлов CSV (без имени файла).
Вот код:
Public Function RefreshLinksToPath(strNewPath As String, _
Optional OnlyForTablesMatching As String = "*") As Boolean
Dim collTbls As New Collection
Dim i As Integer
Dim strDBPath As String
Dim strTbl As String
Dim strMsg As String
Dim strDBName As String
Dim strcon As String
Dim dbCurr As DAO.Database
Dim dbLink As DAO.Database
Dim tdf As TableDef
Set dbCurr = CurrentDb
On Local Error GoTo fRefreshLinks_Err
'First get all linked tables in a collection'
dbCurr.TableDefs.Refresh
For Each tdf In dbCurr.TableDefs
With tdf
If ((.Attributes And TableDefAttributeEnum.dbAttachedTable) = _
TableDefAttributeEnum.dbAttachedTable) _
And (.Name Like OnlyForTablesMatching) Then
Debug.Print "Name: " & .Name
Debug.Print "Connect: " & .Connect
collTbls.Add Item:=.Name & ";" & .Connect, Key:=.Name
End If
End With
Next
Set tdf = Nothing
' Now link all of them'
For i = collTbls.Count To 1 Step -1
strConnRaw = collTbls(i)
' Get table name from the full connection string
strTbl = Left$(strConnRaw, InStr(1, strConnRaw, ";") - 1)
' Get original database path
strDBPath = Right(strConnRaw, Len(strConnRaw) - (InStr(1, strConnRaw, "DATABASE=") + 8))
' Get the name of the linked database
strDBName = Right(strDBPath, Len(strDBPath) - InStrRev(strDBPath, "\"))
' Get remainder of connection string
strConn = Mid(strConnRaw, InStr(1, strConnRaw, ";") + 1, InStr(1, strConnRaw, "DATABASE=") _
- InStr(1, strConnRaw, ";") - 1)
' Reconstruct the full database path with the given path
' CSV-Files are not linked with their name!
If Left(strConn, 4) = "Text" Then
strDBPath = strNewPath
Else
strDBPath = strNewPath & "\" & strDBName
End If
' Reconnect '
Set tdf = dbCurr.TableDefs(strTbl)
With tdf
.Connect = strConn & "Database=" & strDBPath
.RefreshLink
collTbls.Remove (.Name)
End With
Next
RefreshLinksToPath = True
fRefreshLinks_End:
Set collTbls = Nothing
Set tdf = Nothing
Set dbLink = Nothing
Set dbCurr = Nothing
Exit Function
fRefreshLinks_Err:
RefreshLinksToPath = False
Select Case Err
Case 3059:
Case Else:
strMsg = "Error Information..." & vbCrLf & vbCrLf
strMsg = strMsg & "Function: fRefreshLinks" & vbCrLf
strMsg = strMsg & "Description: " & Err.Description & vbCrLf
strMsg = strMsg & "Error #: " & Format$(Err.Number) & vbCrLf
MsgBox strMsg
Resume fRefreshLinks_End
End Select
End Function
К сожалению, я все еще использую Access 2007.Я начал с одного из приведенных выше блоков кода, который у меня не работал.Имея меньше возможностей доступа к vba, я упростил его до первого цикла, который получает пути к таблице и обновляет их на месте.Следующий парень, столкнувшийся с этим, может прокомментировать или обновить.
База данных сравнения вариантов
'------------------------------------------------------------'
' Reconnect all linked tables using the given path. '
' This only needs to be done once after the physical backend '
' has been moved to another location to correctly link to '
' the moved tables again. '
' If the OnlyForTablesMatching parameter is given, then '
' each table name is tested against the LIKE operator for a '
' possible match to this parameter. '
' Only matching tables would be changed. '
' For instance: '
' RefreshLinksToPath(CurrentProject.Path, "local*") '
' Would force all tables whose ane starts with 'local' to be '
' relinked to the current application directory. '
'
' Immediate window type
' RefreshLinksToPath Application.CurrentProject.Path
'------------------------------------------------------------'
Public Function RefreshLinksToPath(strNewPath As String, _
Optional OnlyForTablesMatching As String = "*") As Boolean
Dim strDBPath As String
'Dim strTbl As String
'Dim strMsg As String
Dim strDBName As String
Dim dbCurr As DAO.Database
Dim dbLink As DAO.Database
Dim tdf As TableDef
Set dbCurr = CurrentDb
Dim strConn As String
Dim strNewDbConn1 As String
Dim strNewDbConn2 As String
Dim strNewDbConn As String
' On Local Error GoTo fRefreshLinks_Err
'First get all linked tables in a collection'
dbCurr.TableDefs.Refresh
For Each tdf In dbCurr.TableDefs
With tdf
If ((.Attributes And TableDefAttributeEnum.dbAttachedTable) = TableDefAttributeEnum.dbAttachedTable) _
And (.Name Like OnlyForTablesMatching) Then
strConn = tdf.Connect
strDBPath = Right(strConn, Len(strConn) - (InStr(1, strConn, "DATABASE=") + 8))
strDBName = Right(strDBPath, Len(strDBPath) - InStrRev(strDBPath, "\"))
Debug.Print ("===========================")
Debug.Print (" connect is " + strConn)
Debug.Print (" DB PAth is " + strDBPath)
Debug.Print (" DB Name is " + strDBName)
strDBNewPath = strNewPath & "\" & strDBName
Debug.Print (" DB NewPath is " + strDBNewPath)
strNewDbConn1 = Left(strConn, (InStr(1, strConn, "DATABASE=") - 1))
strNewDbConn2 = "DATABASE=" & strDBNewPath
strNewDbConn = strNewDbConn1 & strNewDbConn2
Debug.Print (" DB strNewDbConn is " + strNewDbConn)
'Change the connect path
tdf.Connect = strNewDbConn
tdf.RefreshLink
End If
End With
Next
End Function