VBA Tipp: Neuverknüpfen des Backends

Aus DBWiki
Wechseln zu: Navigation, Suche

Anforderung

Der Pfad zu den verknüpften Tabellen der Datenbank (Backend) hat sich geändert, weil das entsprechende Verzeichnis verschoben oder umbenannt wurde, etc..
Die Verknüpfung dieser Tabellen soll nun automatisch aktualisiert, und an das neue Backend-Verzeichnis angepasst werden.

Lösung 1

Das folgende Modul realisiert das. Es muss lediglich die Funktion RelinkDb(strPath) aufgerufen werden, wobei in strPath der Name des neuen Verzeichnisses übergeben wird. Der Fortschritt des Vorgangs wird in der Statusleiste angezeigt.

'Quelle: http://www.dbwiki.net/
 
Option Compare Database
Option Explicit
 
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
 
Private dbs As Database
 
' Funktion zum Neuverknüpfen des Backends
'
' strPath: Verzeichnis, in dem das/die Backend(s) liegt/liegen
' (Es darf nur EIN Verzeichnis sein, kann jedoch mehrere BE-Dateien enthalten)
' Rückgabe: True bei Erfolg der kompletten Neuverknüpfung
 
Function RelinkDb(strPath As String) As Boolean
 
   Dim flag       As Boolean
   Dim bStat      As Boolean
   Dim i          As Long
   Dim nCount     As Long
   Dim strFile    As String
   Dim strConnect As String
   Dim tdf        As DAO.TableDef
   Dim rs()       As DAO.Recordset
   Dim cFiles     As New VBA.Collection
 
   On Error GoTo Fehler
 
   If strPath = vbNullString Then Err.Raise 23001, "RelinkDB", "Leere Pfadangabe"
 
   If Right$(strPath, 1) = "\" Then strPath = Left$(strPath, Len(strPath) - 1)
 
   'Testen, ob Verzeichnis Dateien enthält...
   If Dir(strPath & "\*") = vbNullString Then Err.Raise 23002, _
                            "RelinkDB", "Ungülige Pfadangabe"
 
   Set dbs = CurrentDb
   'Zwischenspeicher, ob Statusleiste angezeigt ist...
   bStat = Application.GetOption("Show Status Bar")
   Application.SetOption "Show Status Bar", True   'Statusleiste anzeigen und
   'Meldung "Neuverknüpfen" anzeigen
   SysCmd acSysCmdInitMeter, "Neuverknüpfen der Daten mit dem Backend...", 100
 
   'Testen, ob alle benötigten Dateien im
   'Backendverzeichnis vorhanden sind (s. Funktion unten)
   strFile = TestFilesOK(strPath)
 
   If strFile <> vbNullString Then _
      Err.Raise 23003, "RelinkDB", "Benötigte Datei " & strFile & _
                " nicht gefunden." & vbCrLf & "...Abbruch!"
 
   'Zahl der verknüpften Tabellen ermitteln für Fortschrittsanzeige...
   nCount = dbs.OpenRecordset("SELECT COUNT(*) FROM MSysObjects WHERE " & _
                              "MSysObjects.Database IS NOT NULL", dbOpenSnapshot)(0)
 
   'Diese beiden Optionen sollen den Sperrmechanismus von JET beschleunigen
   DBEngine.SetOption dbLockDelay, 20
   DBEngine.SetOption dbLockRetry, 5
 
   'Alle (verknüpften) Tabellen durchgehen...
   For Each tdf In dbs.TableDefs
 
      'Fortschrittsanzeige in Statusleiste einstellen...
      SysCmd acSysCmdUpdateMeter, , Int(5 + 95 * i / nCount)
 
      strConnect = tdf.Connect
      'Verknüpfte Tabellen haben in der Eigenschaft "Connect" keinen Leer-String...
      '...aber evtl. eine ODBC-/Excel-/ETC.-Verknüpfnung.
      If strConnect <> vbNullString Then
         If Left$(strConnect, 9) = ";DATABASE" Then
            'Diese Tabellen ausschließen.
            i = i + 1
 
            'Dateiname des Backends aus Connect extrahieren; hier kommt die Funktion
            'InstrRev() zum Einsatz, die erst ab A2000 zur Verfügung steht. Einen
            'Ersatz für A97 gibt es hier im Wiki
 
            strFile = Mid(strConnect, 1 + InStrRev(strConnect, "\"))
            On Error Resume Next
            Err.Clear
 
            'Dateinamen zur Collection hinzufügen. Wenn ein gleichnamiger Eintrag
            '(Key!) bereits besteht, schlägt dies fehl. Andernfalls wird flag auf
            'True gesetzt. (s.u. >>FLAG)
 
            cFiles.Add strFile, "1" & strFile
            flag = (Err.Number = 0)
            On Error GoTo Fehler
 
            'Neuen Verknüpfungsstring erzeugen
            strConnect = ";DATABASE=" & strPath & "\" & strFile
 
            'Nur verknüpfen, wenn es wirklich erforderlich ist
            If tdf.Connect <> strConnect Then
               tdf.Connect = strConnect
 
               'Und das ist die eigentliche Verknüpfungsanweisung:
               tdf.RefreshLink
            End If
         End If
      End If
 
      '>> FLAG
      'Wenn auf eine Tabelle im Backend ein Recordset geöffnet wird, so
      'wird die Zahl der Sperrversuche zum Backend von JET herabgesetzt.
      'Dies resultiert in einer höheren Verknüpfungsgeschwindigkeit
      'für die weiteren Tabellen dieses Backend. Nach Erfahrungswerten
      'beschleunigt dies den Vorgang um das 2-3-fache!
      'Deshalb wird hier für jede Backend-Datei genau ein Recordset in
      'einem Recordset-Array geöffnet...
      If flag Then
         ReDim Preserve rs(cFiles.Count - 1)
         Set rs(cFiles.Count - 1) = dbs.OpenRecordset(tdf.Name, dbOpenDynaset)
      End If
 
   Next
 
   'DBEngine-Optionen wieder auf Standardwerte einstellen.
   DBEngine.SetOption dbLockDelay, 100
   DBEngine.SetOption dbLockRetry, 20
 
   dbs.TableDefs.Refresh
   RelinkDb = True
   SysCmd acSysCmdRemoveMeter  'Fortschrittsanzeige in Statusleiste entfernen
   SysCmd acSysCmdSetStatus, " Verknüpfungen OK!"  ' Erfolgsmeldung anzeigen
   Sleep 2000         '...und 2 sek warten, damit man sie auch lesen kann. ;-)
   SysCmd acSysCmdClearStatus
   Application.SetOption "Show Status Bar", bStat  'Statusleiste anzeigen, je nach
                                                   'Zustand vor der Neuverknüpfung
Ende:
   Erase rs    'Recordset-Array löschen; setzt alle Recordsets auf Nothing
   Exit Function
 
Fehler:
   MsgBox Err.Description, vbCritical, "mdlRelink / RelinkDB"
   Resume Ende
 
End Function
 
'Hilfsfunktion, die ermittelt, ob alle notwendigen
'Backend-Dateien im angegebenen Verzeichnis vorhanden sind.
'Rückgabe dann ""; andernfalls String mit Name der fehlenden Datei.
Public Function TestFilesOK(strPath As String) As String
 
   Dim tdf        As TableDef
   Dim strConnect As String
 
   On Error GoTo Fehler
 
   For Each tdf In dbs.TableDefs
      strConnect = tdf.Connect
      If strConnect <> vbNullString Then
         If Left$(strConnect, 9) = ";DATABASE" Then
            strConnect = Mid$(strConnect, 1 + InStrRev(strConnect, "\"))
            If Dir(strPath & "\" & strConnect) = "" Then
               TestFilesOK = strConnect
               'Hier Abbruch, falls Datei fehlt
               Exit For
            End If
         End If
      End If
   Next
 
Ende:
  Exit Function
 
Fehler:
   MsgBox Err.Description, vbCritical, "mdlRelink / TestFilesOK"
 
End Function

Lösung 2

Einfachere Variante:

  • Schritt 1: Alle vorhandenen Tabelleneinbindungen im Frontend werden gelöscht.
  • Schritt 2: Alle im Backend vorhandenen Tabellen (außer Systemtabellen) werden neu ins Frontend eingebunden.

Die Funktion wird in einem globalen Modul gespeichert.

Public Function TabellenEinbinden()
 
   'Quelle: http://www.dbwiki.net/
 
   Dim dbFE        As DAO.Database
   Dim dbBE        As DAO.Database
   Dim rs          As DAO.Recordset
   Dim tdf         As DAO.TableDef
   Dim col         As VBA.Collection
   Dim i           As Integer
   Dim strBEpfad   As String
 
   'Voller Pfad des Backends
   strBEpfad = CurrentProject.Path & "\EinBackend.mdb"
 
   Set dbFE = CurrentDb
   Set dbBE = DBEngine.Workspaces(0).OpenDatabase(strBEpfad)
   Set col = New VBA.Collection
 
   'Alle eingebundenen Tabellen im Frontend löschen
   Set rs = dbFE.OpenRecordset("SELECT * FROM MSysObjects WHERE Type = 6")
 
   If Not (rs.BOF And rs.EOF) Then
      rs.MoveFirst
 
      Do Until rs.EOF
         dbFE.TableDefs.Delete rs!Name
         rs.MoveNext
      Loop
   End If
 
   'Backend-Tabellennamen in Collection einlesen, ohne Systemtabellen
   For i = 0 To dbBE.TableDefs.Count - 1
      'wenn ungleich "MSys"
      If Left$(dbBE.TableDefs(i).Name, 4) <> "MSys" Then
         col.Add dbBE.TableDefs(i).Name
      End If
   Next
 
   'Tabellen einbinden, Collection mit den Tabellennamen durchlaufen
   For i = 1 To col.Count
 
      'TableDef-Objekt im Frontend erstellen und Tabellennamen zuweisen
      Set tdf = dbFE.CreateTableDef(col(i))
 
      'TableDef-Objekt verbinden mit der BE-Datenbank
      tdf.Connect = ";DATABASE=" & strBEpfad
 
      'Backend-Tabelle der Frontend-Tabelle als Quelle zuweisen
      tdf.SourceTableName = col(i)
 
      'TableDef-Objekt der TableDefs-Auflistung des Frontends anfügen
      dbFE.TableDefs.Append tdf
 
   Next
 
   'Speicher freigeben
   dbFE.Close
   dbBE.Close
 
   'Eingebundene Tabellen im Datenbankfenster sofort sichtbar machen
   '(nur optischer Effekt, für die Funktion nicht erforderlich)
   Application.RefreshDatabaseWindow
 
End Function

Aufruf

Per VBA:

   Call TabellenEinbinden

Per Makro:
Die Funktion kann auch im Autoexec-Makro beim Start der Datenbank ausgeführt werden.
AusführenCode Funktionsname =TabellenEinbinden()

Wikilinks