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

[SPOILER]'--------------------------------------------------------------------
' Module    : modLinkTablesMySQL
' Author    : es
' Date      : 21.08.2016
' Purpose   : Подлинковка таблиц MySQL с автоматическим созданием DSN (ADOX или DAO)
'--------------------------------------------------------------------------
'Требуются ссылки на:
'    Microsoft ADO Ext. for DDL and Security. (Version 2.1 or higher)
'    Microsoft ActiveX Data Objects Library. (Version 2.1 or higher)
'--------------------------------------------------------------------
 
Public Sub LinkTablesMySQL_ADOX()
'Создание общей строки подключения и подлинковка таблиц MySQL
'--------------------------------------------------------------------------
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 sConnect As String
Dim l&
 
'--------------------------------------------------------------------------
On Error GoTo LinkTablesMySQL_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
 
'On Error GoTo LinkTablesMySQL_ADOX_Err
'Внимание - проверь версию драйвера! - Может уже... 5.5 или даже 6.2!?
    'sDriver = "{MySQL ODBC 5.2 ANSI Driver}"    'ANSI Driver
    'sDriver = "{MySQL ODBC 3.51 Driver}"  'UNICODE Driver
    
    'sServerAdr = "localhost"
    sServerAdr = "111.111.1.111"   ' Адрес (Имя) сервера
    sServPort = "3306"         ' Порт соединения = 3306 (Обычно так и есть)
    sDbName = "111" ' Название базы
    sUser = "m1256t"             ' Имя пользователя
    sPassWord = "111111"    ' Пароль
 
 
'Создаю строку подключения:
 sConnect = "ODBC;DRIVER=" & sDriver & _
        ";SERVER=" & sServerAdr & _
        ";Port=" & sServPort & _
        ";DATABASE=" & sDbName & _
        ";USER=" & sUser & _
        ";PASSWORD=" & sPassWord & _
        ";OPTION=3" & _
        ";stmt=set names cp1251"
        'Debug.Print sConnect
 
'--------------------------------------------------------------------
'Подключаем несколько таблиц по ADOX
  
l = LinkTable_ADOX("Amper", sConnect)
    If l > 0 Then Err.Raise l
 
l = LinkTable_ADOX("Progr", sConnect)
    If l > 0 Then Err.Raise l
    
l = LinkTable_ADOX("Proizvod", sConnect)
    If l > 0 Then Err.Raise l
 
l = LinkTable_ADOX("R_RA", sConnect)
    If l > 0 Then Err.Raise l
    
l = LinkTable_ADOX("Rabota_Robotov", sConnect)
    If l > 0 Then Err.Raise l
 
l = LinkTable_ADOX("Requ_For_Specialty", sConnect)
    If l > 0 Then Err.Raise l
    
l = LinkTable_ADOX("Site", sConnect)
    If l > 0 Then Err.Raise l
 
l = LinkTable_ADOX("Sites_1", sConnect)
    If l > 0 Then Err.Raise l
    
l = LinkTable_ADOX("Texprocecc", sConnect)
    If l > 0 Then Err.Raise l
 
l = LinkTable_ADOX("Tip_Dokym", sConnect)
    If l > 0 Then Err.Raise l
    
l = LinkTable_ADOX("Tip_Operaciy", sConnect)
    If l > 0 Then Err.Raise l
 
l = LinkTable_ADOX("To_I_R", sConnect)
    If l > 0 Then Err.Raise l
    
l = LinkTable_ADOX("To_I_R_Prichina", sConnect)
    If l > 0 Then Err.Raise l
 
l = LinkTable_ADOX("To_Izd", sConnect)
    If l > 0 Then Err.Raise l
    
l = LinkTable_ADOX("To_Izd_Cpicok_Rab", sConnect)
    If l > 0 Then Err.Raise l
 
l = LinkTable_ADOX("To_Obor_Cpicok_Rab", sConnect)
    If l > 0 Then Err.Raise l
    
l = LinkTable_ADOX("Verciy_PO", sConnect)
    If l > 0 Then Err.Raise l
 
l = LinkTable_ADOX("Verciy_Po_Aktualn", sConnect)
    If l > 0 Then Err.Raise l
    
l = LinkTable_ADOX("Vid_Rabot", sConnect)
    If l > 0 Then Err.Raise l
 
l = LinkTable_ADOX("Vid_Rabot_To", sConnect)
    If l > 0 Then Err.Raise l
    
l = LinkTable_ADOX("Vizm_Neicpr_Napominal", sConnect)
    If l > 0 Then Err.Raise l
 
l = LinkTable_ADOX("Volt", sConnect)
    If l > 0 Then Err.Raise l
    
l = LinkTable_ADOX("Vozvrat_Iz_Otk", sConnect)
    If l > 0 Then Err.Raise l
 
l = LinkTable_ADOX("Vxod_Kontrol", sConnect)
    If l > 0 Then Err.Raise l
    
l = LinkTable_ADOX("Zakaz", sConnect)
    If l > 0 Then Err.Raise l
 
l = LinkTable_ADOX("Zakazchik", sConnect)
    If l > 0 Then Err.Raise l
    
l = LinkTable_ADOX("Zip", sConnect)
    If l > 0 Then Err.Raise l
 
l = LinkTable_ADOX("Zip_Cklad", sConnect)
    If l > 0 Then Err.Raise l
    
l = LinkTable_ADOX("Zip_Cklad_Racxod", sConnect)
    If l > 0 Then Err.Raise l
 
l = LinkTable_ADOX("Zip_Dvigenie", sConnect)
    If l > 0 Then Err.Raise l
    
l = LinkTable_ADOX("Zip_Imia", sConnect)
    If l > 0 Then Err.Raise l
 
l = LinkTable_ADOX("Zip_Mex_Cbor", sConnect)
    If l > 0 Then Err.Raise l
 
l = LinkTable_ADOX("Zip_Partiy", sConnect)
    If l > 0 Then Err.Raise l
    
l = LinkTable_ADOX("Zip_Partiy_Brem_Nakleika", sConnect)
    If l > 0 Then Err.Raise l
 
l = LinkTable_ADOX("Zip_Poctavshik", sConnect)
    If l > 0 Then Err.Raise l
    
l = LinkTable_ADOX("Zip_Vid", sConnect)
    If l > 0 Then Err.Raise l
 
l = LinkTable_ADOX("Zip_Ynikaln", sConnect)
    If l > 0 Then Err.Raise l
    
l = LinkTable_ADOX("Izdelie_Verciy_PO", sConnect)
    If l > 0 Then Err.Raise l
 
 
 DoCmd.OpenForm "fEnter1"
  
 
'--------------------------------------------------------------------------
'Подключаем пару таблиц по DAO
    'l = LinkTable_DAO("Ablom", sConnect, "Volt_DAO")
    'If l > 0 Then Err.Raise l
    
    'l = LinkTable_DAO("Cklad", sConnect, "Cklad_DAO")
    'If l > 0 Then Err.Raise l
 
        
LinkTablesMySQL_ADOX_Bye:
    Exit Sub
 
LinkTablesMySQL_ADOX_Err:
    MsgBox "Ошибка " & Err.Number & vbCrLf & Err.Description & vbCrLf & "в процедуре: LinkTablesMySQL_ADOX", vbCritical, "Error in module modConnectMySQL_DAO"
    Resume LinkTablesMySQL_ADOX_Bye
End Sub
 
 
Private Function LinkTable_ADOX(stRemTName As String, strConnect As String, Optional sLocalTName As String = "") As Long
'es 21.08.2016
'Подключение к таблице MySQL Server с автоматическим созданием DSN (ADOX)
'При удачном подключениии возвращает = 0 (ноль), при неудачном = КОД ОШИБКИ (номер)
'-------------------------------------------------------------------------
'Аргументы:
'   stRemTName  = Имя таблицы на сервере
'   strConnect  = Строка подключения к серверу
'   sLocalTName = Локальное Имя Таблицы
'-------------------------------------------------------------------------
Dim cat As New ADOX.Catalog
Dim tbl As New ADOX.Table
    
On Err GoTo LinkTable_ADOX_Err
 
'Если локальное имя не указанно
    If sLocalTName = "" Then sLocalTName = stRemTName
    
'Открываем каталог текущей базы
    Set cat.ActiveConnection = CurrentProject.Connection
    
'Если таблица с таким названием уже существует - Удаляем
    For Each tbl In cat.Tables
        If tbl.Name = sLocalTName Then cat.Tables.Delete tbl.Name
    Next
    
'Установка параметров таблицы
    With tbl
        .Name = sLocalTName
        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
    CurrentDb.TableDefs.Refresh
    DoEvents
 
LinkTable_ADOX_Bye:
    Set cat = Nothing
    Set tbl = Nothing
    Exit Function
 
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 Function
 
 
Private Function LinkTable_DAO(sSourceTblName As String, sConnectStr As String, Optional sLocalTblName As String = "") As Long
'es - 29.12.2012
'Создаёт подлинкованную таблицу по параметрам подключения с автоматическим созданием DSN (DAO)
'При удачном подключениии возвращает = 0 (ноль), при неудачном = КОД ОШИБКИ (номер)
'--------------------------------------------------------------------
'Аргументы:
'   sSourceTblName  = Имя Таблицы Исходное (на сервере)
'   sConnectStr     = Строка подключения к серверу:
'   sLocalTblTName  = Локальное Имя Таблицы (по умолчанию = sSourceTblName)
'--------------------------------------------------------------------
Dim tdf As New DAO.TableDef
    If sLocalTblName = "" Then sLocalTblName = sSourceTblName
'Удаляем старую подлинковку (если была)
    On Error Resume Next
    CurrentDb.TableDefs.Delete sLocalTblName
    Err.Clear
   
On Error GoTo LinkTable_DAO_Err
'Установка параметров создаваемой таблицы
    With tdf
        .Name = sLocalTblName
        .Connect = sConnectStr
        .SourceTableName = sSourceTblName
    End With
    
'Создаём новый обьект Таблица
    CurrentDb.TableDefs.Append tdf
    DoEvents
    CurrentDb.TableDefs.Refresh
    
LinkTable_DAO_Bye:
    On Error Resume Next
    Set tdf = Nothing
    Exit Function
 
LinkTable_DAO_Err:
    LinkTable_DAO = Err.Number
    Debug.Print "Error " & Err.Number & vbCrLf & Err.Description & vbCrLf & _
        "in procedure LinkTable_DAO", vbCritical, "Error!"
    Resume LinkTable_DAO_Bye
End Function[/SPOILER]

Public Const AConnStr_ADO$ = "Provider=MSDASQL;DRIVER={MySQL ODBC 5.3 Unicode Driver};" & _
                            "SERVER=XXX.XXX.XX.XXX;DATABASE=db_name;" & _
                            "USER=User_Name;PASSWORD=XXXXXXXX;Interactive=1;" & _
                            "OPTION=3;"

Dim arrTables() As Variant
Dim i%, s$, l&
 
'Массив табличек:
    arrTables = Array("tbl01", "tbl02", "tbl03", "tbl04", "tbl05", "tbl06") ' и т.д. ...
 
'Обработка всех таблиц в массиве:
    For i = LBound(arrTables) To UBound(arrTables)
        s = arrTables(i) 'Имя таблицы
        l = LinkTable_ADOX(s, sConnect)
        If l > 0 Then 
            Err.Raise l
            Exit for
        end if
    Next i

Dim arrTables() As Variant
Dim i%, s$, l&
 
'Массив табличек:
    arrTables = Array("tbl01", "tbl02", "tbl03", "tbl04", "tbl05", "tbl06") ' и т.д. ...
    arrTables_1 = Array("tbl11", "tbl12", "tbl13", "tbl14", "tbl15", "tbl16") ' и т.д. ...
    arrTables_2 = Array("tbl33", "tbl42", "tbl56", "tbl58", "tbl60", "tbl61") ' и т.д. ...
'Обработка всех таблиц в массиве:
    For i = LBound(arrTables) To UBound(arrTables)
        s = arrTables(i) 'Имя таблицы
        l = LinkTable_ADOX(s, sConnect)
        If l > 0 Then 
            Err.Raise l
            Exit for
        end if
    Next i

Sub Main
    Dim arrTables() As Variant
'Массив табличек:
    arrTables = Array("tbl01", "tbl02", "tbl03", "tbl04", "tbl05", "tbl06") ' и т.д. ...
    Link_Tables arrTables
    arrTables = Array("tbl11", "tbl12", "tbl13", "tbl14", "tbl15", "tbl16") ' и т.д. ...
    Link_Tables arrTables
    arrTables = Array("tbl33", "tbl42", "tbl56", "tbl58", "tbl60", "tbl61") ' и т.д. ...
    Link_Tables arrTables
End Sub
 
Sub Link_Tables(arrTables())
'Обработка всех таблиц в массиве:
    For i = LBound(arrTables) To UBound(arrTables)
        s = arrTables(i) 'Имя таблицы
        l = LinkTable_ADOX(s, sConnect)
        If l > 0 Then 
            Err.Raise l
            Exit for
        end if
    Next i  
End Sub

Sub DeleteLinks(arrTables())
   Dim i
   For i=LBound(arrTables) To UBound(arrTables)
       currentdb.execute "drop table [" & arrTables(i) & "]"
   next
End Sub

Public Sub DelConnectedTables()
' Удаляет из базы все подлинкованные таблицы
'--------------------------------------------------------------------
Dim cat As ADOX.Catalog
Dim tbl As ADOX.Table
Dim i As Integer
On Error GoTo DelConnectedTablesErr
 
    Set cat = New ADOX.Catalog
    cat.ActiveConnection = CurrentProject.Connection
    
    For Each tbl In cat.Tables
        If tbl.Properties("Jet OLEDB:Create Link") = True Then
            'Debug.Print tbl.Name
            'CurrentDb.Execute "drop table [" & tbl.Name & "]" 'как вариант
            CurrentDb.TableDefs.Delete tbl.Name
        End If
    Next
   
DelConnectedTablesBye:
    Set cat = Nothing
    Set tbl = Nothing
    Exit Sub
 
DelConnectedTablesErr:
    MsgBox "Произошла ошибка при удалении подключенных таблиц:" & vbCrLf & _
    Err.Description, vbCritical
    Resume DelConnectedTablesBye
End Sub

Sub DeleteLinks(arrTables())
   Dim i
   For i=LBound(arrTables) To UBound(arrTables)
       currentdb.execute "drop table [" & arrTables(i) & "]"
   next
End Sub

Sub Link_Tables(arrTables())
'Обработка всех таблиц в массиве:
    For i = LBound(arrTables) To UBound(arrTables)
        s = arrTables(i) 'Имя таблицы
        l = LinkTable_ADOX(s, sConnect)
        If l > 0 Then 
            Err.Raise l
            Exit for
        end if
    Next i  
End Sub

    Dim arrTables01() As Variant
'Массив табличек:
    arrTables01 = Array("tbl01", "tbl02", "tbl03", "tbl04", "tbl05", "tbl06") ' и т.д. ...
    Link_Tables arrTables01 'Подлинковка по массиву в аргументе

Dim arrTables01() As Variant
'Массив табличек:
    arrTables01 = Array("tbl01", "tbl02", "tbl03", "tbl04", "tbl05", "tbl06") ' и т.д. ...
    Link_Tables arrTables01 'Подлинковка по массиву в аргументе