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

我需要能够提供一种方法来更新Access数据库中所有ODBC链接表连接中的服务器名称。所有表都已迁移出对SQL Express实例的访问权限。需要一个选项来更新所有外部表链接，使其从“Localhost\SQLExpress”指向另一台服务器上的SQL实例。数据库名称将保持一致。只需要更新服务器实例名称

我已经找到了一些示例，说明了如何对访问数据库文件和Excel文件的连接执行此操作，而不是对SQL Server的ODBC连接执行此操作。这里的一篇文章指出需要对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

---

代码示例就是我想到的。有一条注释指示发生数据类型转换错误的点。我想我需要知道这是否是可能的，或者我是否正在尝试做一些不可能的事情，或者只是以错误的方式进行…

我们使用此代码调用AttachSqlServer，其中需要四个参数：

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

公共函数连接字符串（_
ByVal主机名作为字符串_
ByVal数据库作为字符串_
ByVal用户名作为字符串_
ByVal密码（作为字符串）_
作为字符串
'从其变量元素创建ODBC连接字符串。
' 2016-04-24. 仙人掌数据ApS，CPH。
Const AzureDomain As String=“.windows.net”
常量OdbcConnect作为字符串=_
“ODBC；”和_
“驱动程序=SQL Server本机客户端11.0；”&_
“Description=应用程序名称；”&_
“应用程序=Microsoft？Access；”&_
“服务器={0}；”&_
“数据库={1}；”&_
“UID={2}；”&_
“PWD={3}；”&_
“受信任的_连接={4}；”
'Const cstrConnect As String=_
““ODBC；驱动程序=SQL Server本机客户端11.0；服务器=（localdb）\MSSQLSLocalDB；数据库=测试；受信任的连接=是”
Dim FullConnect作为字符串
如果正确（主机名，Len（AzureDomain））=AzureDomain，则
'Azure SQL连接。
'将服务器名附加到用户名。
用户名=用户名&“@”和拆分（主机名）（0）
如果结束
FullConnect=OdbcConnect
FullConnect=Replace（FullConnect，{0}，主机名）
FullConnect=Replace（FullConnect，“{1}”，数据库）
FullConnect=Replace（FullConnect，“{2}”，用户名）
FullConnect=Replace（FullConnect，“{3}”，密码）
FullConnect=Replace（FullConnect，“{4}”，IIf（用户名和密码=”，“是”，“否”））
ConnectionString=FullConnect
端函数
公用函数附加QLServer（_
ByVal主机名作为字符串_
ByVal数据库作为字符串_
ByVal用户名作为字符串_
ByVal密码（作为字符串）_
作为布尔值
'将通过ODBC链接的所有表附加到SQL Server或Azure SQL。
' 2016-04-24. 仙人掌数据ApS，CPH。
常量cstrDbType为String=“ODBC”
常量cstrAcPrefix为String=“dbo_389;”
Dim数据库作为DAO.Database
将tdf调暗为DAO.TableDef
将qdf设置为DAO.QueryDef
作为字符串的Dim strConnect
将strName设置为字符串
错误转到Err_AttachSqlServer
设置dbs=CurrentDb
strConnect=ConnectionString（主机名、数据库、用户名、密码）
对于dbs.TableDefs中的每个tdf
strName=tdf.Name
如果Asc（strName）Asc（“~”），则
如果InStr（tdf.Connect，cstrDbType）=1，则
如果左（strName，Len（cstrAcPrefix））=cstrAcPrefix，则
tdf.Name=Mid（strName，Len（cstrAcPrefix）+1）
如果结束
tdf.Connect=strConnect
刷新链接
Debug.Print Timer，tdf.Name，tdf.SourceTableName，tdf.Connect
多芬特
如果结束
如果结束
下一个
对于dbs.querydfs中的每个qdf
如果是qdf.Connect“”，则
Debug.Print Timer，qdf.Name，qdf.Type，qdf.Connect
qdf.Connect=strConnect
如果结束
下一个
调试。打印“完成！”
AttachSqlServer=True
退出\u AttachSqlServer：
设置tdf=无
设置dbs=Nothing
退出功能
Err_AttachSqlServer:
“打电话给ErrorMox
恢复退出\u AttachSqlServer
端函数

太棒了！这很有魅力。我想我遗漏的关键部分是刷新链接。