Attribute VB_Name = "AutoPatch"
Option Compare Database
Option Explicit

'НАЗНАЧЕНИЕ: Автоматическое подключение таблиц серверной части в разделенных БД MS Access.
'
'За основу взят модуль AutoPatch автора AlexP, выложенный 02.02.2008 по адресу:
'http://accessoft.ru/forum/topic50.html

'Настройки модуля:
Const IniFileName As String = "Storage.ini" 'имя ini-файла, в котором хранится путь к БД.
Const IniFileSectionName As String = "Main" 'название секции ini-файла.
Const dbExt As String = "accdb"
'Настройки завершены.

Dim DATADbName As Variant
Dim DBLink As String
Dim LastDBPath As String 'последний указанный каталог (чтобы было легче открывать несколько баз подряд)
Dim TotalLinkedTables As Integer
Dim LinkedTables As Integer

Public Function CheckReferences()
Dim rstDB As DAO.Recordset
Dim LinkedBaseID As Long
Dim dbs As Database, tdf As TableDef
Dim LinkedTablesInfo As Variant, k As Integer
    
'    Set dbs = CurrentDb
'    For Each tdf In dbs.TableDefs
'       LinkedTablesInfo = tdf.Connect
'        If Len(LinkedTablesInfo) = 0 Then
'        MyMsg "Len(LinkedTablesInfo) = 0"
'        Call SetReferences
'        Exit Function
'        End If
'    Next tdf

If readini("Storage.ini", "Main", "RelinkTables", "0") = "1" Then
writeini "Storage.ini", "Main", "RelinkTables", "0"
Call SetReferences 'переподключаем связи
Exit Function
End If

'попробуем найти хоть одну запись в подключенной таблице
On Error GoTo ErrorHandler
If DCount("UseriD", "User") = 0 Then
Call SetReferences
Exit Function
End If

'проверяем наличие баз данных
Set rstDB = CurrentDb.OpenRecordset("LinkedBase")
With rstDB
    Do While Not .EOF
    
    'Читаем путь к базе:
    DBLink = readini(IniFileName, IniFileSectionName, !LinkedBaseName)
    If DBLink = "DefaultValue" Or Len(Dir(DBLink)) = 0 Then 'если путь к базе="" или файл базы не найден
    Call SetReferences 'переподключаем связи
    Exit Function
    End If
    
    .MoveNext
    Loop
    .Close
End With
Set rstDB = Nothing

Exit Function

Exit_:
Exit Function

ErrorHandler:
Call SetReferences
Resume Exit_
End Function

Public Function SetReferences()
On Error GoTo Err_
Dim rstDB As DAO.Recordset
Dim rstTable As DAO.Recordset
Dim LinkedBaseID As Long

TotalLinkedTables = DCount("LinkedTableName", "LinkedTable")
LinkedTables = 0

LastDBPath = ""

On Error Resume Next
ClearTablesRef 'удаляем из Access информацию о подключенных таблицах

Set rstDB = CurrentDb.OpenRecordset("LinkedBase")
With rstDB
    Do While Not .EOF
    'Читаем путь к базе:
    DBLink = readini(IniFileName, IniFileSectionName, !LinkedBaseName)
    'если путь к базе="" или файл базы не найден
    If DBLink = "DefaultValue" Or Len(Dir(DBLink)) = 0 Then
        DBLink = LastDBPath & !LinkedBaseName & "." & dbExt
        If Len(Dir(DBLink)) = 0 Then
        Call GetDBLink(!LinkedBaseName)
        Else
        'получив путь, сохраним его в ini-файле:
        writeini IniFileName, IniFileSectionName, !LinkedBaseName, DBLink
        End If
    End If
    DATADbName = DBLink
    LinkedBaseID = !LinkedBaseID
    'Application.RefreshTitleBar
        Set rstTable = CurrentDb.OpenRecordset( _
        "SELECT LinkedTableName " & _
        "FROM LinkedTable " & _
        "WHERE LinkedBaseID=" & !LinkedBaseID)
        With rstTable
            Do While Not .EOF
            'подключаем таблицы из списка таблиц
                Call SetTableRef(!LinkedTableName)
                .MoveNext
            Loop
            .Close
        End With
    .MoveNext
    Loop
    .Close
End With

Exit_:
    Set rstDB = Nothing
    Set rstTable = Nothing
    Exit Function
Err_:
    MsgBox Err.Description
    DoCmd.Quit
    Resume Exit_
End Function

Sub ClearTablesRef()
'процедура удаляет информацию о всех подключенных таблицах
Dim dbs As Database, tdf As TableDef
Dim LinkedTablesInfo As Variant, k As Integer
    Set dbs = CurrentDb
Start_:
    For Each tdf In dbs.TableDefs
       LinkedTablesInfo = tdf.Connect
        If Len(LinkedTablesInfo) > 0 Then
            dbs.TableDefs.Delete (tdf.Name)
            GoTo Start_
        End If
    Next tdf
End Sub

Sub SetTableRef(LinkedTableName As String)
'процедура подключает таблицу.
On Error GoTo Err_
    If IsTable(LinkedTableName) <> 1 Then 'если к базе не подключена такая таблица
    DoCmd.TransferDatabase acLink, "Microsoft Access", DBLink, acTable, LinkedTableName, LinkedTableName, False, False
    LinkedTables = LinkedTables + 1
    Form_StartupScreen.ProgressBar = CStr((LinkedTables * 100) \ TotalLinkedTables) & " %"
    End If
Exit_:
    Exit Sub
Err_:
    MsgBox Err.Description
    DoCmd.Quit
End Sub

Sub GetDBLink(DBName As String)
'процедура запрашивает у юзера путь к БД.
If MsgBox(DBName & "." & dbExt & " is not found!" & " " & _
"Press OK to open the database or Cancel to Exit", _
vbOKCancel + vbExclamation, "Database connection failed") <> vbOK Then
DoCmd.Quit
Exit Sub
End If
Start_:
DBLink = fOpenFileDialog("Open the " & DBName & "." & dbExt, LastDBPath, "Access 2007 (*.accdb)")
If DBLink = "" Then
    DoCmd.Quit
    Exit Sub
End If
If InStr(1, DBLink, DBName, vbBinaryCompare) = 0 Then
MsgBox "You have selected the wrong database!", vbExclamation + vbOKOnly
GoTo Start_
End If
'получив путь, сохраним его в ini-файле:
writeini IniFileName, IniFileSectionName, DBName, DBLink
LastDBPath = Left(DBLink, Len(DBLink) - Len(DBName & "." & dbExt))
End Sub

Function fOpenFileDialog(strTitle As String, strFolder As String, strFilter As String) As String
On Error GoTo Err_
Dim strFile As String
    WizHook.Key = 51488399
    WizHook.GetFileName 0, "AppName", strTitle, "", strFile, strFolder, strFilter, 0, 0, 0, True
    fOpenFileDialog = strFile
Exit_:
    Exit Function
Err_:
    MsgBox Err.Description
    Err.Clear
    Resume Exit_
End Function

Function IsTable(Name As String) As Integer
'Если к базе уже подключена таблица Name, то IsTable=1, иначе IsTable=0.
Dim dbs As Database, tdf As TableDef
    Set dbs = CurrentDb
    For Each tdf In dbs.TableDefs
        If tdf.Name = Name Then
            IsTable = 1
            Exit Function
        End If
    Next tdf
    IsTable = 0
End Function