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.

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
' Quelle: www.dbwiki.net oder www.dbwiki.de
'
' 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, bStat As Boolean
Dim i As Long, nCount As Long
Dim strFile As String, 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 = "") 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 & "\*") = "" 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 <> "" Then Err.Raise 23003, "RelinkDB", _
                        "Benötigte Datei " & strFile & " nicht gefunden." & _
                        vbNewLine & "...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)
  i = 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 <> "" 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 tdf
  ' 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
  Set cFiles = Nothing
  Set tdf = Nothing
  Set dbs = 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, strConnect As String
On Error GoTo Fehler
 
  For Each tdf In dbs.TableDefs
    strConnect = tdf.Connect
    If strConnect <> "" 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 tdf
 
Ende:
  Set tdf = Nothing
  Exit Function
 
Fehler:
  MsgBox Err.Description, vbCritical, "mdlRelink / TestFilesOK"
  Resume Ende
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: www.dbwiki.net oder www.dbwiki.de
 
 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 & "\MeinBackend.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 i
 
 '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
 
   Set tdf = Nothing
 
 Next i
 
 Set col = Nothing
 'Speicher freigeben
 If Not dbFE Is Nothing Then dbFE.Close: Set dbFE = Nothing
 If Not dbBE Is Nothing Then dbBE.Close: Set dbBE = Nothing
 
 '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()

Wiki-Links