Function newPathAuto(PString As String, OldPString As String) As Integer
On Error GoTo err_newPathAuto
    newPathAuto = - 1 
    DoCmd.Hourglass True
    Dim MyWork As Workspace, BD As Database ', OldPString
    'Dim i_Table As String 'TableDef
    Dim dfTable As TableDef
    Dim rst As Recordset
    Set MyWork = DBEngine.Workspaces(0)
    Set BD = MyWork.Databases(0)
    BD.TableDefs.Refresh
    Set rst = BD.OpenRecordset("_Connected_Tables", DB_OPEN_DYNASET)
    rst.MoveLast
    rst.MoveFirst
    Dim imax As Integer, i As Integer
    Dim tdfName As String
        imax = rst.RecordCount
        For i = 1 To imax
            If rst("Database") & "" <> "" Then
                tdfName = rst.Fields("Name")
                Set dfTable = BD.TableDefs(tdfName)
                'If dfTable.Connect = IIf((rst.Fields("connect") & "") <> "", rst.Fields("connect"), ";") & "DATABASE=" & OldPString Then
                If rst.Fields("DATABASE") = OldPString Then
                    dfTable.Connect = IIf((rst.Fields("connect") & "") <> "", rst.Fields("connect"), ";") & "DATABASE=" & PString
                    dfTable.RefreshLink
                End If
            End If
            rst.MoveNext
        Next i
        
exit_newPathAuto:
    'logPrint "Подключение " & PString & " " & (newPathAuto <> 0)
    Set MyWork = Nothing
    Set BD = Nothing
    Set dfTable = Nothing
    DoCmd.Hourglass False
    Exit Function
err_newPathAuto:
    newPathAuto = 0
    If Not dfTable Is Nothing Then
        tdfName = dfTable.Name
    Else
        tdfName = ""
    End If
    MsgBox "Ошибка подключения " & err & " in " & tdfName
    'Debug.Print "Ошибка подключения " & Err & " in " & tdfName
    'logPrint "Ошибка подключения " & Err & " in " & tdfName
    Resume exit_newPathAuto: 'Next '
End Function

SELECT DISTINCTROW MSysObjects.Database, MSysObjects.Connect, MSysObjects.ForeignName, MSysObjects.Name
FROM MSysObjects
WHERE (((MSysObjects.Database) Is Not Null)) OR (((MSysObjects.Connect) Is Not Null));