Actualizar vínculos o enlaces externos en Access

Access tiene la posibilidad de crear vínculos  o enlaces externos a otras fuentes de datos. Hasta aquí todo bien. El problema surge cuando movemos la base de datos a otra ubicación, porque Access guarda la ruta absoluta a las fuentes externas de datos. Para unas situaciones está bien y para otras nos hace la vida imposible sin avisar.

A continuación os muestro un código de VBA para insertar en una macro de Access para que lo podamos ejecutar cuando queramos o automáticamente cuando abramos la base de datos:

Option Compare Database
Option Explicit

Public Function UpdateLinks() As Boolean
    
    Dim cmdSQL As String
    Dim db As DAO.Database
    Dim rs As DAO.Recordset
    Dim Database As String
    Dim DirDatabase As String
    Dim RefName As String
    Dim sName As String
    Dim sLinkBegin As String
    Dim sLinkEnd As String
    Dim ID As Long
    Dim updateRef As Boolean
    
    Set db = CurrentDb()
    Database = db.Name
    DirDatabase = GetPath(CurrentDb().Name)
    
    cmdSQL = «SELECT * FROM MSysObjects WHERE Type = 6″
    Set rs = db.OpenRecordset(cmdSQL, dbOpenSnapshot)
    
    While Not rs.EOF
        ID = rs(«ID»)
        sLinkBegin = rs(«Database»)
        sName = rs(«Name»)
        RefName = Filename(sLinkBegin)
        sLinkEnd = DirDatabase & RefName
        
        updateRef = False
        If (Not FileExists(sLinkBegin)) And FileExists(sLinkEnd) Then
            updateRef = True
        End If
        If sLinkBegin <> sLinkEnd And FileExists(sLinkBegin) And FileExists(sLinkEnd) Then
            If VbMsgBoxResult.vbOK = MsgBox(«Actualizar referencia » & sLinkBegin & » por la referencia » & sLinkEnd & «?», vbOKCancel, «Actualizar referencias«) Then
                updateRef = True
            End If
        End If
            
        If updateRef Then
            ‘Herramientas> Referencias…
            ‘Añadir: Microsoft ADO Ext 2.5 (o posterior) for DDL and Security.
            ‘objCat.Tables(sName).Type = «LINK»
            Dim objCat As New ADOX.Catalog ‘Define the ADOX Catalog Object
            objCat.ActiveConnection = CurrentProject.Connection
            objCat.Tables(sName).Properties(«Jet OLEDB:Link Datasource«) = sLinkEnd
        End If
        rs.MoveNext
    Wend
    
    rs.Close
    db.Close
End Function

Private Function GetPath(path_and_filename As String) As String
    Dim path As String
    Dim posicionPath As Integer
    
    posicionPath = InStrRev(path_and_filename, «\»)
    path = Left(path_and_filename, posicionPath)
    GetPath = path
End Function

Private Function FileExists(Filename As String) As Boolean
    FileExists = (Dir(Filename) > «»)
End Function

Private Function Filename(ByVal strPath As String) As String
    If Right$(strPath, 1) <> «\» And Len(strPath) > 0 Then
        Filename = Filename(Left$(strPath, Len(strPath) – 1)) + Right$(strPath, 1)
    End If
End Function