Option Compare Database
Option Explicit

 ' Использовать переопределение связей с таблицами 
#Const Apply_Redefine_TableDef =  1 
#Const Apply_Redefine_TableDef_v1 =  1 

 ' Использовать переопределение связей с запросами к серверу 
#Const Apply_Redefine_QeryDef =  1 

 ' Использовать TurboPower Software Suite 
#Const UseTurboPowerSuite =  0 

 ' Глобальные декларации 
   
 ' несуществующий логин. В этом случае в системном окне "Вход в сервер SQL" 
 ' пользователь должен будет ввести и логин и пароль. 
Public Const strUID As String = "UID=(не указан);"
Public Const strPWD As String = "PWD=;"

Public cn_str   As String            ' строка подключения 
Public cn_MyDb  As DAO.Connection    ' соединение с БД 
Public ws_MyDb  As DAO.Workspace     ' рабочая область 
Public db_MyMdb As DAO.Database      ' копия свойства CurrentDB 

Private Const strProvider    As String = "ODBC;"
Private Const strDriver      As String = "DRIVER=SQL Server;"

Private Const strServer      As String = "SERVER=MYSERVER;"
Private Const strDatabase    As String = "Database=MYDBTEST;"
Private Const strAddress     As String = "Address=MYSERVER,1433"
Private Const strNetwork     As String = "Network=DBMSSOCN;"

Public Sub OpenODBCDirectConnection()
 ' Устанавливает связь с БД, переопределяет строки подключения 
 ' связанных таблиц и запросов к серверу. 
   
    Dim i, j As Integer

#If Apply_Redefine_TableDef_v1 =  1  Then
    Dim td As DAO.TableDef
    Dim tbl As DAO.TableDef
#End If
    
     ' формируем строку подключения 
    cn_str = strProvider & strDriver & strServer & strDatabase & _
        strUID & strPWD
 ' "третий стакан" 
 '        strNetwork & _ 
 '        strAddress 
    
     ' --- Подключаем БД --- 
     ' Создаем рабочую область ODBCDirect. Передаем пустые name, user и password, 
     ' так как подключение и авторизацию будем осуществлять через OpenConnection, 
     ' используя строку подключения. Помним о том, что непустой параметр Name 
     ' в CreateWorkspace принуждает к излишнему поиску DSN с именем Name. 
    Set ws_MyDb = CreateWorkspace("", "", "", dbUseODBC)
   
     ' Устанавливаем подключение: пусть dbDriverCompleteRequired 
     ' разрешит пользователю доввести только недостающие сведения 
    Set cn_MyDb = ws_MyDb.OpenConnection( _
       "", dbDriverCompleteRequired, , cn_str)
    
     ' сохраняем строку подключения после авторизации 
    cn_str = cn_MyDb.Connect
    
    Set db_MyMdb = CurrentDb

#If Apply_Redefine_TableDef =  1  Then
     ' Переопределяем строки подключения связанных таблиц 
    With db_MyMdb
        #If Apply_Redefine_TableDef_v1 =  0  Then
             '--- сканируем коллекцию таблиц 
            j = .TableDefs.Count  ' всего таблиц в коллекции 
            For i =  0  To j -  1 
                If Len(.TableDefs(i).SourceTableName) <>  0  Then
                    ' связанная таблица - переопределяем 
                    ' строку подключения и освежаем связь 
                   .TableDefs(i).Connect = cn_str
                   .TableDefs(i).RefreshLink
                End If
            Next i
        #Else
            For Each td In .TableDefs
                If td.Connect <> "" Then
                    DoCmd.RunSQL "DROP TABLE [" & td.Name & "]"
                    DoCmd.TransferDatabase acQuery, "ODBC", _
                        cn_str, acTable, td.SourceTableName, td.Name
                End If
            Next
        #End If
    End With
    .TableDefs.Refresh   ' освежаем состояние коллекции TableDefs 
#End If

#If Apply_Redefine_QeryDef =  1  Then
     ' Переопределяем строки подключения запросов к серверу 
    With db_MyMdb
         '--- сканируем коллекцию запросов --- 
        j = .QueryDefs.Count  ' всего запросов в коллекции 
        For i =  0  To j -  1 
            If .QueryDefs(i).Type = dbQAction Or .QueryDefs(i).Type = dbQProcedure Then
                 ' запрос вида "действие" или "хранимая процедура". 
                 ' переопределяем строку подключения 
                .QueryDefs(i).Connect = cn_str
            End If
        Next i
        .QueryDefs.Refresh  ' освежим состояние коллекции QueryDefs 
    End With
#End If

End Sub

Sub ShowErrMsg(Optional Caption As String)
    MsgBox "Ошибка № " & err.Number & vbNewLine & _
        err.Description, vbCritical + vbOKOnly, Caption
End Sub

Public Function IsLoaded(ByVal strFormName As String) As Boolean
 ' Заимствована из базы данных "Борей" (NorthWin.mdb), 
    Const conObjStateClosed =  0 
    Const conDesignView =  0 
    If SysCmd(acSysCmdGetObjectState, acForm, strFormName) <> conObjStateClosed Then
        If Forms(strFormName).CurrentView <> conDesignView Then
            IsLoaded = True
        End If
    End If
End Function

Public Function ЗакрытьФормуЕслиЗагружена(ByVal strFormName As String)
 ' Закрывает форму strFormName, если она загружена 
    On Error GoTo ErrHandler
    If IsLoaded(strFormName) Then DoCmd.Close acForm, strFormName
ExitSub:
    Exit Function
ErrHandler:
    ShowErrMsg
    Resume ExitSub
End Function

 ' Стартовая форма frmStartUp 

Private Sub Form_Open(Cancel As Integer)
     ' Главная форма с элементами, источник данных которых   
     ' зависит от текущего логина 
    OpenODBCDirectConnection
    DoCmd.OpenForm "frmMain"
End Sub

 ' Форма frmMain 

Private Sub Form_Open(Cancel As Integer)
    On Error GoTo ErrHandler
    ЗакрытьФормуЕслиЗагружена "frmStartUp"
     ' Остальной код 
     ' ... 
ExitSub:
    Exit Sub
ErrHandler:
    ShowErrMsg Me.Caption
    Resume ExitSub
End Sub

    ...
    .TableDefs(i).Connect = ""
    .QueryDefs(i).Connect = "ODBC;"
    ...
    Application.Quit acQuitSaveAll