Verlinkte Access Datenbanken umziehen lassen
Ich muss gelegentlich eine Access-Datenbank umziehen lassen, die auf diverse verlinkte Datenbanken zugreift (um das 2 GB Maximum zu umgehen). Da die Verlinkungen absolut sind und nicht relativ, muss man jede Verlinkung nach dem Umzug manuell anpassen, was bei mehr als 100 Tabellen mühselig und fehlerträchtig ist. Basierend auf Code von Stackexchange/Stackoverflow habe ich daher ein paar Hilfsfunktionen gebaut, die den Umzug deutlich vereinfachen. Die Annahme
Der Code besteht aus mehreren Funktionen:
getDatabaseName()extrahiert den Namen der Datenbank aus dem PfadGetFolder()verlinkeTabellenNeu()biegt die Links auf die Datenbankdateien um
fragt beim Nutzer den Pfad ab, in dem die neuen Datenbank-Dateien liegen.
Hinweis: Es empfiehlt sich nach Abschluss ein Auslesen aller Verlinkungen und Abgleichen z.B. in Excel, um auf Nummer sicher gehen zu können, dass alle Verlinkungen erfolgreich waren. Zum Auslesen der Verlinkungen kann man den Code unten am Ende des Artikels nutzen.
Option Compare Database
Function getDatabaseName(currentPath As String)
' Uwe Ziegenhagen, 2017-11-03
' Extrahiert den Namen der Datenbank aus dem Pfad,
' wertet dazu die Position des letzten "\" aus:
' von innen nach außen:
' kehre String um
' finde den letzten Backslash
' nimm den substring bis zum letzten Backslash
' reverse diesen Substring wieder
getDatabaseName = StrReverse(Left(StrReverse(currentPath), InStr(StrReverse(currentPath), "\") - 1))
End Function
Function GetFolder() As String
' https://stackoverflow.com/questions/26392482/vba-excel-to-prompt-user-response-to-select-folder-and-return-the-path-as-string
' based on https://www.ozgrid.com/forum/forum/help-forums/excel-general/126180-getfolder-function?t=182343
' requires references to Microsoft Office xx.0 Object library
Dim fldr As FileDialog
Dim sItem As String
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
.Title = "Select a Folder"
.AllowMultiSelect = False
'.InitialFileName = Application.DefaultFilePath
If .Show <> -1 Then GoTo NextCode
sItem = .SelectedItems(1)
End With
NextCode:
GetFolder = sItem
Set fldr = Nothing
End Function
Sub verlinkeTabellenNeu()
' Uwe Ziegenhagen, 2017-11-03
' Ruft vom User einen Pfad ab und verlinkt alle Tabellen mit diesem Pfad neu
' based on code from https://stackoverflow.com/questions/4928134/changing-linked-table-location-programatically
ordnerNeu = GetFolder()
Dim dbs As DAO.Database
Dim tdf As DAO.TableDef
Set dbs = CurrentDb()
With dbs
For Each tdf In .TableDefs
'Is the table a linked table?
If tdf.Attributes And dbAttachedODBC Or tdf.Attributes And dbAttachedTable Then
With tdf
oldPath = .Properties("Connect").Value
.Connect = ";DATABASE=" & ordnerNeu & "\" & getDatabaseName(.Properties("Connect").Value)
.RefreshLink
Debug.Print oldPath & "@@@" & .Properties("Connect").Value
End With
End If
Next tdf
End With
End Sub |
Code zum Auslesen der Verlinkungen
Sub LinkedTableConnection()
' http://p2p.wrox.com/access-vba/37117-finding-linked-tables.html
Dim dbs As DAO.Database
Dim tdf As DAO.TableDef
Set dbs = CurrentDb()
With dbs
For Each tdf In .TableDefs
'Is the table a linked table?
If tdf.Attributes And dbAttachedODBC Or tdf.Attributes And dbAttachedTable Then
With tdf
' Connect property contains path of link
' Debug.Print "Connect Property of " & .Name & " is: " & .Properties("Connect").Value
Debug.Print "kompletter Pfad: " & tdf.Connect
' Debug.Print "Name der Datenbank: " & getDatabaseName(.Properties("Connect").Value)
End With
End If
Next tdf
End With
End Sub |
