Код VBA для линковки (установлении связи) по двум или более драйверам ODBC

Public arrTables01() As Variant

Option Compare Database
Option Explicit
 
'--------------------------------------------------------------------------
' Module    : modLink_MySQL_ADOX
' Author    : es
' Date      : 24.07.2017
' Purpose   : Переподключение таблиц MySQL без DSN
'--------------------------------------------------------------------------
' - Требует установки MySQL ODBC ODBC MySQL драйвера
'--------------------------------------------------------------------------
'Требуются ссылки на:
'    Microsoft ADO Ext. for DDL and Security. (Version 2.1 or higher)
'    Microsoft ActiveX Data Objects Library. (Version 2.1 or higher)
'--------------------------------------------------------------------------
 
 
Public ConnStr$
Private cat As ADOX.Catalog
Private tbl As ADOX.Table
Private AConnectionString_ADOX As String
Private i%, s$
 
Public Sub StartReLink_MySQL_ADOX(Optional bDelOnly As Boolean)
'Собственно процедура подключения (основная)
 
Dim arrTables() As Variant
 
'--------------------------------------------------------------------------
On Error GoTo StartReLink_MySQL_ADOX_Err
    DoCmd.Hourglass True 'Показать часики
 
 
'Массив табличек:
    arrTables = Array("Amper", "Baza", "Baza_Pitatel", "Cat_Empl", "Chet", "Chet_Kompl", "Cklad", _
        "Cklad_Dvig_Izd", "Cod_Empl", "Cotrydnik", "Cpecifikaciy", "Cpecifikaciy_Pza1", _
        "Cpocob_Per_Zak", "Cpr_Dorabotok", "Ctr_Izd_Modyl", "Ctr_Izd_Ocnov", "Ctrana", _
        "Ctryktyra_Izdely", "Cvoictva_Znach", "Cvoictvo_Detali", "Dolznoct", "Dop_Zamena", _
        "Edinicy_Izmereny", "Forma_Cobctv", "Funk_Claim", "Funk_Otvetctv_Za_Vip", _
        "Funk_Pol_Inform", "Funk_Procecc", "Funk_Structure", "Funk_View", "Funk_Ychactv_V_Vip", _
        "Gorod", "Grup_Empl", "Gryp_Clozn_Rem", "Icpolnenie", "Identifikator_Izd", _
        "Invent_Cklad", "Izdelie", "Izdelie_Komplekty", "Izdelie_Modifikaciy", "Izdelie_TO", _
        "Izdely_Gryp", "Izv_Cogl", "Izv_Cogl_Jyrnal_Cob", "Izv_Ctatyc", "Izv_Formylirovki", _
        "Izv_Izdelie", "Izv_Jyrnal_Cob", "Izv_Koment", "Izv_Koment_Jyrnal_Cob", "Izv_Modul", _
        "Izv_Vid_Cogl", "Izveshenie", "Level_Competence", "Mecto_Xraneniy", "Modifikaciy", _
        "Modyl", "Name_Funk", "Name_Group", "NameFunk", "Necootvetctv", "Oboryd_TO", _
        "Oborydovanie", "Ogr_Cpicok", "ooDecim_Nomer", "ooGryppa_Izd", "ooKlacc_Izd", _
        "ooPodgryppa_Izd", "ooPodklacc_Izd", "ooPor_Regictr_Nomer", "ooVid_Izd", "Operaciy_Cklad", _
        "Operaciy_Oboryd", "Operaciy_Texnol", "Operaciy_Vipol", "Opicanie_Cvoictv", "Org_Ctrykt", _
        "Organizat_Role", "Otdel", "Pitatel", "Pitatel_Partia", "Plata_Defekt", "Poctavchik", _
        "Porycheniy", "Prichina_Vozvr_Iz_OTK", "Privyzka_Coctava", "Process", "Process_A", "Progr", _
        "Proizvod", "R_RA", "Rabota_Robotov", "Requ_For_Specialty", "Site", "Sites_1", "Texprocecc", _
        "Tip_Dokym", "Tip_Operaciy", "To_I_R", "To_I_R_Prichina", "To_Izd", "To_Izd_Cpicok_Rab", _
        "To_Obor_Cpicok_Rab", "Verciy_PO", "Verciy_Po_Aktualn", "Vid_Rabot", "Vid_Rabot_To", _
        "Vizm_Neicpr_Napominal", "Volt", "Vozvrat_Iz_Otk", "Vxod_Kontrol", "Zakaz", "Zakazchik", _
        "Zip", "Zip_Cklad", "Zip_Cklad_Racxod", "Zip_Dvigenie", "Zip_Imia", "Zip_Mex_Cbor", _
        "Zip_Partiy", "Zip_Partiy_Brem_Nakleika", "Zip_Poctavshik", "Zip_Vid", "Zip_Ynikaln", "Izdelie_Verciy_PO")
 
'--------------------------------------------------------------------------
'Предварительный промсмотр (если нужно):
    Debug.Print String(74, "-")
    For i = LBound(arrTables) To UBound(arrTables)
        s = arrTables(i)
        Debug.Print Format(i + 1, "000"); ".  " & s
    Next i
    Debug.Print String(74, "-")
    Debug.Print "Всего: " & Format(i, "00") & " таблиц " & Now
    Debug.Print String(74, "-")
'--------------------------------------------------------------------------
    'GoTo StartReLink_MySQL_ADOX_Bye
    
'Запуск
    ReLinkTables_ADOX arrTables, "00_", bDelOnly    ' Полное переподключение
 
StartReLink_MySQL_ADOX_Bye:
    DoCmd.Hourglass False 'Вернуть нормальный курсор
    Exit Sub
 
StartReLink_MySQL_ADOX_Err:
    MsgBox "Error: " & Err.Number & vbCrLf & Err.Description & vbCrLf & _
    "in procedure: StartReLink_MySQL_ADOX in module: modLink_MySQL_ADOX", _
    vbCritical, "Error in Application!": Err.Clear
    Resume StartReLink_MySQL_ADOX_Bye
        
End Sub
 
Private Sub ReLinkTables_ADOX(arrTables() As Variant, Optional sTblLocalPrefix$ = "", Optional bDelOnly As Boolean)
' Вспомогательная -  Переподключение таблиц по массиву
'--------------------------------------------------------------------------
'Аргументы:
'   arrTables()      = Массив табличек
'   sTblLocalPrefix  = Локальный префикс названий
'   bDelONly         = Только удалить и не подключать если = True (-1)
'--------------------------------------------------------------------------
Dim sTblName$
Dim sDriver As String
Dim sServerAdr As String
Dim sCharset As String
Dim sServPort As String
Dim sDbName As String
Dim sUser As String
Dim sPassWord As String
Dim l&
 
On Error GoTo ReLinkTables_ADOX_Err
 
    
    If Dir("C:\Program Files\MySQL\Connector ODBC 3.51", vbDirectory) <> "" Then
        sDriver = "{MySQL ODBC 3.51 Driver}" 'Папка Connector ODBC 3.51 существует. Драйвер для 32 разрядной операционной системы(для устаревших компьютеров- где дополниетльные программы (требующиеся для работы этого драйвера) плохо или не ставятся вовобще)
    ElseIf Dir("C:\Program Files\MySQL\Connector ODBC 5.3", vbDirectory) <> "" Then
        sDriver = "{MySQL ODBC 5.3 Unicode Driver}" 'Драйвер для 32 или драйвер для 64 разрядного MS Office - в зависимости , что установлено. Имя папки одинаковое.
    Else
        MsgBox "Нет драйвера ODBC для работы с  MySQL"
        Exit Sub
    End If
 
    'sServerAdr = "localhost"
    sServerAdr = "111.111.1.111"   ' Адрес (Имя) сервера
    sServPort = "3306"         ' Порт соединения = 3306 (Обычно так и есть)
    sDbName = "111" ' Название базы
    sUser = "mmmmmm"             ' Имя пользователя
    sPassWord = "11111111"    ' Пароль
 
s = ""
'Создаю строку подключения:
 ConnStr = "MSDASQL;DRIVER=" & sDriver & _
        ";SERVER=" & sServerAdr & _
        ";Port=" & sServPort & _
        ";DATABASE=" & sDbName & _
        ";USER=" & sUser & _
        ";PASSWORD=" & sPassWord & _
        ";OPTION=3" & _
        ";stmt=set names cp1251"
        Debug.Print ConnStr
        Debug.Print String(74, "-")
    
    
'Строим строку подключения ... - добавляем "ODBC;" в начало уже готовой (см выше)
    AConnectionString_ADOX = "ODBC;" & ConnStr
 
'Катплог
    Set cat = New ADOX.Catalog
    'Открываем каталог текущей базы
    Set cat.ActiveConnection = CurrentProject.Connection
 
'Удаление всех таблиц по именам
     For i = LBound(arrTables) To UBound(arrTables)
        sTblName = arrTables(i)
        s = sTblLocalPrefix & sTblName
        DelTable_ADOX s
    Next i
    cat.Tables.Refresh
    Debug.Print String(74, "-")
 
    If bDelOnly = True Then GoTo ReLinkTables_ADOX_Bye
'Подключение  всех по именам
    For i = LBound(arrTables) To UBound(arrTables)
        sTblName = arrTables(i)
        'Debug.Print Format(i, "000") & " - " & sTblName
        LinkTable_ADOX sTblName, AConnectionString_ADOX, sTblLocalPrefix & sTblName
    Next i
    
'Отчёт о проделанной работе
    'Debug.Print String(74, "-")
    Debug.Print "Подключено: " & Format(i, "000") & " таблиц " & Now
    Debug.Print String(74, "-")
 
    
ReLinkTables_ADOX_Bye:
    On Error Resume Next
    'Обновляем список таблиц
    cat.Tables.Refresh
    
    cat.ActiveConnection.Close
    Set cat = Nothing
    Set tbl = Nothing
    
    'Keep_ADO_Connection
    Exit Sub 'Ура!!!
 
ReLinkTables_ADOX_Err:
    s = "Error " & Err.Number & vbCrLf & Err.Description & vbCrLf & _
    "In procedure: ReLinkTables_ADOX in module: modCommon_ADOX"
    Debug.Print s
    MsgBox s, vbCritical, "Error in Application!"
    Err.Clear
    Resume ReLinkTables_ADOX_Bye
End Sub
Private Sub DelTable_ADOX(s$)
'Удаление подлинковки.
    On Error Resume Next
    cat.Tables.Delete s
    If Err = 0 Then Debug.Print s & " ... Deleted!"
    Err.Clear
End Sub
 
Private Sub LinkTable_ADOX(stRemTName As String, strConnect As String, Optional strLocalTableName As String = "")
'es 08.05.2017
'Подлинковка таблички MySQL Server с автоматическим созданием DSN (ADOX)
'Использует общие переменные данного модуля (так короче и возможно быстрее)
'-------------------------------------------------------------------------
'Аргументы:
'   stRemTName  = Имя таблицы на сервере
'   strConnect  = Строка подключения к серверу с "ODBC:DRIVER = ..."
'   strLocalTableName = Локальное Имя Таблицы
'-------------------------------------------------------------------------
 
On Err GoTo LinkTable_ADOX_Err
'Если локальное имя не указанно
    If strLocalTableName = "" Then strLocalTableName = stRemTName
    
     Set tbl = New ADOX.Table
 
'Установка параметров таблицы
    With tbl
        .Name = strLocalTableName
        Set .ParentCatalog = cat
        .Properties("Jet OLEDB:Link Provider String") = strConnect
        .Properties("Jet OLEDB:Remote Table Name") = stRemTName
        .Properties("Jet OLEDB:Create Link") = True
    End With
    
'Создаём новый обьект
    cat.Tables.Append tbl
    cat.Tables.Refresh
    
LinkTable_ADOX_Bye:
    Exit Sub
 
LinkTable_ADOX_Err:
    'LinkTable_ADOX = Err.Number
    Debug.Print "Error " & Err.Number & vbCrLf & Err.Description & vbCrLf & _
            "in Function: esLinkTable_ADOX"
    Resume LinkTable_ADOX_Bye
End Sub

'Запуск
    ReLinkTables_ADOX arrTables, "00_", bDelOnly    ' Полное переподключение

'Запуск
    ReLinkTables_ADOX arrTables, , bDelOnly    ' Полное пере-подключение

sTblLocalPrefix