如何使用访问VBA更新所有ODBC链接SQL Server表的服务器名称

Question

我需要能够提供一种在访问数据库中所有ODBC链接表连接中更新服务器名称的方法。所有表都已迁移到对SQL Express实例的访问中。需要一个选项将所有外部表链接更新以从" Local -Host SQLEXPRESS"指向另一台服务器上的SQL实例。数据库名称将保持一致。仅需要更新服务器实例名称。

我找到了如何执行此操作以访问数据库文件和Excel文件的示例，而不是ODBC连接到SQL Server。这里的一篇文章指出需要维数DB对象并直接使用它，而不是尝试直接使用CurrentDB。这使我更进一步，但是现在，当试图将新连接字符串分配到TableDef时，代码会失败。

Dim OldServer As String
Dim NewServer As String
Dim OldPath As String
Dim NewPath As String
Dim strPath As String
NewServer = Me.NewServerInstance ' get new Server Instance name from form
OldPath = GetCurrentPath("Version")
'Parse old name from the ODBC connection string
OldServer = Replace(Left(OldPath, InStr(GetCurrentPath("Version"), "UID=") - 2), "ODBC Driver 13 for SQL Server;SERVER=", "")
NewPath = Replace(OldPath, OldServer, NewServer)
If NewServer = OldServer Then
GoTo UpdateInstance_Click_Exit
Else
    'update all table connection strings. 
    'Loop & replace Old server instance with New server instance
    Dim Db As DAO.Database
    Set Db = CurrentDb
    Dim td As DAO.TableDef
    For Each td In Db.TableDefs
        If (td.Attributes And dbAttachedODBC) = dbAttachedODBC Then
            Db.TableDefs(td).Connect = NewPath 'getting a datatype conversion error here...
            Db.TableDefs(td).RefreshLink
'           MsgBox (db.TableDefs(td).Connect)
        End If
    Next
End If

代码示例是我提出的。有评论指示发生数据类型转换误差的点。我想我需要知道这是否可以，或者我是否正在尝试做不可能的事情，或者只是以错误的方式进行操作...

Answer 1

我们使用此代码，您可以在其中调用 attactsqlserver ，其中需要四个参数：

Public Function ConnectionString( _
    ByVal Hostname As String, _
    ByVal Database As String, _
    ByVal Username As String, _
    ByVal Password As String) _
    As String
' Create ODBC connection string from its variable elements.
' 2016-04-24. Cactus Data ApS, CPH.
    Const AzureDomain   As String = ".windows.net"
    Const OdbcConnect   As String = _
        "ODBC;" & _
        "DRIVER=SQL Server Native Client 11.0;" & _
        "Description=Application Name;" & _
        "APP=Microsoft? Access;" & _
        "SERVER={0};" & _
        "DATABASE={1};" & _
        "UID={2};" & _
        "PWD={3};" & _
        "Trusted_Connection={4};"
'    Const cstrConnect   As String = _
'        "ODBC;Driver=SQL Server Native Client 11.0;Server=(localdb)MSSQLLocalDB;Database=Test;Trusted_Connection=Yes"
    Dim FullConnect     As String
    If Right(Hostname, Len(AzureDomain)) = AzureDomain Then
        ' Azure SQL connection.
        ' Append servername to username.
        Username = Username & "@" & Split(Hostname)(0)
    End If
    FullConnect = OdbcConnect
    FullConnect = Replace(FullConnect, "{0}", Hostname)
    FullConnect = Replace(FullConnect, "{1}", Database)
    FullConnect = Replace(FullConnect, "{2}", Username)
    FullConnect = Replace(FullConnect, "{3}", Password)
    FullConnect = Replace(FullConnect, "{4}", IIf(Username & Password = "", "Yes", "No"))
    ConnectionString = FullConnect
End Function
Public Function AttachSqlServer( _
    ByVal Hostname As String, _
    ByVal Database As String, _
    ByVal Username As String, _
    ByVal Password As String) _
    As Boolean
' Attach all tables linked via ODBC to SQL Server or Azure SQL.
' 2016-04-24. Cactus Data ApS, CPH.
    Const cstrDbType    As String = "ODBC"
    Const cstrAcPrefix  As String = "dbo_"
    Dim dbs             As DAO.Database
    Dim tdf             As DAO.TableDef
    Dim qdf             As DAO.QueryDef
    Dim strConnect      As String
    Dim strName         As String
    On Error GoTo Err_AttachSqlServer
    Set dbs = CurrentDb
    strConnect = ConnectionString(Hostname, Database, Username, Password)
    For Each tdf In dbs.TableDefs
        strName = tdf.Name
        If Asc(strName) <> Asc("~") Then
            If InStr(tdf.Connect, cstrDbType) = 1 Then
                If Left(strName, Len(cstrAcPrefix)) = cstrAcPrefix Then
                    tdf.Name = Mid(strName, Len(cstrAcPrefix) + 1)
                End If
                tdf.Connect = strConnect
                tdf.RefreshLink
                Debug.Print Timer, tdf.Name, tdf.SourceTableName, tdf.Connect
                DoEvents
            End If
        End If
    Next
    For Each qdf In dbs.QueryDefs
        If qdf.Connect <> "" Then
            Debug.Print Timer, qdf.Name, qdf.Type, qdf.Connect
            qdf.Connect = strConnect
        End If
    Next
    Debug.Print "Done!"
    AttachSqlServer = True
Exit_AttachSqlServer:
    Set tdf = Nothing
    Set dbs = Nothing
    Exit Function
Err_AttachSqlServer:
 '   Call ErrorMox
    Resume Exit_AttachSqlServer
End Function