Altered http://www.accessmvp.com/djsteele/DSNLessLinks.html

Option Compare Database

'***************** Code Start **************

Type TableDetails
    TableName As String
    SourceTableName As String
    Attributes As Long
    IndexSQL As String
    Description As Variant
End Type

Sub FixConnections( _
    ServerName As String, _
    DatabaseName As String, _
    Optional UID As String, _
    Optional PWD As String _
)
' This code was originally written by
' Doug Steele, MVP  [email protected]
' Modifications suggested by
' George Hepworth, MVP   [email protected]
'
' You are free to use it in any application
' provided the copyright notice is left unchanged.
'
' Description:  This subroutine looks for any TableDef objects in the
'               database which have a connection string, and changes the
'               Connect property of those TableDef objects to use a
'               DSN-less connection.
'               It then looks for any QueryDef objects in the database
'               which have a connection string, and changes the Connect
'               property of those pass-through queries to use the same
'               DSN-less connection.
'               This specific routine connects to the specified SQL Server
'               database on a specified server.
'               If a user ID and password are provided, it assumes
'               SQL Server Security is being used.
'               If no user ID and password are provided, it assumes
'               trusted connection (Windows Security).
'
' Inputs:   ServerName:     Name of the SQL Server server (string)
'           DatabaseName:   Name of the database on that server (string)
'           UID:            User ID if using SQL Server Security (string)
'           PWD:            Password if using SQL Server Security (string)
'

On Error GoTo Err_FixConnections

Dim dbCurrent As DAO.Database
Dim prpCurrent As DAO.Property
Dim tdfCurrent As DAO.TableDef
Dim qdfCurrent As DAO.QueryDef
Dim intLoop As Integer
Dim intToChange As Integer
Dim strConnectionString As String
Dim strDescription As String
Dim strQdfConnect As String
Dim typNewTables() As TableDetails

' Start by checking whether using Trusted Connection or SQL Server Security

  If (Len(UID) > 0 And Len(PWD) = 0) Or (Len(UID) = 0 And Len(PWD) > 0) Then
    MsgBox "Must supply both User ID and Password to use SQL Server Security.", _
      vbCritical + vbOKOnly, "Security Information Incorrect."
    Exit Sub
  Else
    If Len(UID) > 0 And Len(PWD) > 0 Then

' Use SQL Server Security

      strConnectionString = "ODBC;DRIVER={sql server};" & _
        "DATABASE=" & DatabaseName & ";" & _
        "SERVER=" & ServerName & ";" & _
        "UID=" & UID & ";" & _
        "PWD=" & PWD & ";"
    Else

' Use Trusted Connection
' ALTER NOFFIE, Made to look more like what was already working for us in previous server

      strConnectionString = "ODBC;DRIVER=SQL Server;" & _
        "SERVER=" & ServerName & ";APP=Microsoft Office 2016;WSID=WS-001;" & _
        "DATABASE=" & DatabaseName & ";" & _
        "Trusted_Connection=YES;"
    End If
  End If

  intToChange = 0

  Set dbCurrent = DBEngine.Workspaces(0).Databases(0)

' Build a list of all of the connected TableDefs and
' the tables to which they're connected.

  For Each tdfCurrent In dbCurrent.TableDefs
    If Len(tdfCurrent.Connect) > 0 Then
      If UCase$(Left$(tdfCurrent.Connect, 5)) = "ODBC;" Then
        ReDim Preserve typNewTables(0 To intToChange)
        typNewTables(intToChange).Attributes = tdfCurrent.Attributes
        typNewTables(intToChange).TableName = tdfCurrent.Name
        typNewTables(intToChange).SourceTableName = tdfCurrent.SourceTableName
        typNewTables(intToChange).IndexSQL = GenerateIndexSQL(tdfCurrent.Name)
        typNewTables(intToChange).Description = Null
        typNewTables(intToChange).Description = tdfCurrent.Properties("Description")
        intToChange = intToChange + 1
      End If
    End If
  Next

' Loop through all of the linked tables we found

  For intLoop = 0 To (intToChange - 1)

' Delete the existing TableDef object

    dbCurrent.TableDefs.Delete typNewTables(intLoop).TableName

' Create a new TableDef object, using the DSN-less connection

    Set tdfCurrent = dbCurrent.CreateTableDef(typNewTables(intLoop).TableName)
    tdfCurrent.Connect = strConnectionString

' Unfortunately, I'm current unable to test this code,
' but I've been told trying this line of code is failing for most people...
' If it doesn't work for you, just leave it out.

' ALTER NOFFIE I did what the comment above says and commented this line out
'    tdfCurrent.Attributes = typNewTables(intLoop).Attributes

    tdfCurrent.SourceTableName = typNewTables(intLoop).SourceTableName
    dbCurrent.TableDefs.Append tdfCurrent

' Where it existed, add the Description property to the new table.

    If IsNull(typNewTables(intLoop).Description) = False Then
      strDescription = CStr(typNewTables(intLoop).Description)
      Set prpCurrent = tdfCurrent.CreateProperty("Description", dbText, strDescription)
      tdfCurrent.Properties.Append prpCurrent
    End If

' Where it existed, create the __UniqueIndex index on the new table.

    If Len(typNewTables(intLoop).IndexSQL) > 0 Then
      dbCurrent.Execute typNewTables(intLoop).IndexSQL, dbFailOnError
    End If
  Next

' Loop through all the QueryDef objects looked for pass-through queries to change.
' Note that, unlike TableDef objects, you do not have to delete and re-add the
' QueryDef objects: it's sufficient simply to change the Connect property.
' The reason for the changes to the error trapping are because of the scenario
' described in Addendum 6 below.

  For Each qdfCurrent In dbCurrent.QueryDefs
    On Error Resume Next
    strQdfConnect = qdfCurrent.Connect
    On Error GoTo Err_FixConnections
    If Len(strQdfConnect) > 0 Then
      If UCase$(Left$(qdfCurrent.Connect, 5)) = "ODBC;" Then
        qdfCurrent.Connect = strConnectionString
      End If
    End If
    strQdfConnect = vbNullString
  Next qdfCurrent

End_FixConnections:
  Set tdfCurrent = Nothing
  Set dbCurrent = Nothing
  Exit Sub

Err_FixConnections:
' Specific error trapping added for Error 3291
' (Syntax error in CREATE INDEX statement.), since that's what many
' people were encountering with the old code.
' Also added error trapping for Error 3270 (Property Not Found.)
' to handle tables which don't have a description.

  Select Case Err.Number
    Case 3270
      Resume Next
    Case 3291
      MsgBox "Problem creating the Index using" & vbCrLf & _
        typNewTables(intLoop).IndexSQL, _
        vbOKOnly + vbCritical, "Fix Connections"
      Resume End_FixConnections
    Case 18456
      MsgBox "Wrong User ID or Password.", _
        vbOKOnly + vbCritical, "Fix Connections"
      Resume End_FixConnections
    Case Else
      MsgBox Err.Description & " (" & Err.Number & ") encountered", _
        vbOKOnly + vbCritical, "Fix Connections"
      Resume End_FixConnections
  End Select

End Sub

Function GenerateIndexSQL(TableName As String) As String
' This code was originally written by
' Doug Steele, MVP  [email protected]
' Modifications suggested by
' George Hepworth, MVP   [email protected]
'
' You are free to use it in any application,
' provided the copyright notice is left unchanged.
'
' Description: Linked Tables should have an index __uniqueindex.
'              This function looks for that index in a given
'              table and creates an SQL statement which can
'              recreate that index.
'              (There appears to be no other way to do this!)
'              If no such index exists, the function returns an
'              empty string ("").
'
' Inputs:   TableDefObject: Reference to a Table (TableDef object)
'
' Returns:  An SQL string (or an empty string)
'

On Error GoTo Err_GenerateIndexSQL

Dim dbCurr As DAO.Database
Dim idxCurr As DAO.Index
Dim fldCurr As DAO.Field
Dim strSQL As String
Dim tdfCurr As DAO.TableDef

  Set dbCurr = CurrentDb()
  Set tdfCurr = dbCurr.TableDefs(TableName)

  If tdfCurr.Indexes.Count > 0 Then

' Ensure that there's actually an index named
' "__UnigueIndex" in the table

    On Error Resume Next
    Set idxCurr = tdfCurr.Indexes("__uniqueindex")
    If Err.Number = 0 Then
      On Error GoTo Err_GenerateIndexSQL

' Loop through all of the fields in the index,
' adding them to the SQL statement

      If idxCurr.Fields.Count > 0 Then
        strSQL = "CREATE INDEX __UniqueIndex ON [" & TableName & "] ("
        For Each fldCurr In idxCurr.Fields
          strSQL = strSQL & "[" & fldCurr.Name & "], "
        Next

' Remove the trailing comma and space

        strSQL = Left$(strSQL, Len(strSQL) - 2) & ")"
      End If
    End If
  End If

End_GenerateIndexSQL:
  Set fldCurr = Nothing
  Set tdfCurr = Nothing
  Set dbCurr = Nothing
  GenerateIndexSQL = strSQL
  Exit Function

Err_GenerateIndexSQL:
' Error number 3265 is "Not found in this collection
' (in other words, either the tablename is invalid, or
' it doesn't have an index named __uniqueindex)
  If Err.Number <> 3265 Then
    MsgBox Err.Description & " (" & Err.Number & ") encountered", _
      vbOKOnly + vbCritical, "Generate Index SQL"
  End If
  Resume End_GenerateIndexSQL

End Function

'************** Code End *****************