This is not quite what your after, but the code can be modified to meet your needs. I use the following code for when the password for the backend Db password needs to be changed (as the front-end can no longer access the tables); first, it retrieves the current linked table’s details, then deletes the linked table and finally re-links the table with the new password.
Also I think you need to look at normalizing your Db
Private Sub Form_Load()
On Error Resume Next
ChangeTableDetails
DoCmd.Close acForm, Me.FormName
End Sub
Public Function ChangeTableDetails()
Dim dbs As DAO.Database
Dim tdf As DAO.TableDef
Dim tdfLinked As DAO.TableDef
Dim strGetCurrentLinkedPath As String
Dim strGetCurrentLinkedTableName As String
Dim intTableCounter As Integer
Dim intNumberOfTables As Integer
Const strBackendTargetDbPassword = ";PWD=plajsgbd"
On Error GoTo ErrorDetected
Set dbs = CurrentDb
dbs.TableDefs.Refresh
intNumberOfTables = dbs.TableDefs.Count
For Each tdf In dbs.TableDefs
If Nz(tdf.Connect, "") <> "" Then
'Store current linked table details
strGetCurrentLinkedTableName = tdf.Name
strGetCurrentLinkedPath = tdf.Connect
strGetCurrentLinkedPath = FindDatabasePathFr0mLinkedString(strGetCurrentLinkedPath)
'Delete current linked table
DoCmd.DeleteObject acTable, tdf.Name
'Rebuild linked table from stored data
'Ensure the password is correct
Set tdfLinked = dbs.CreateTableDef(strGetCurrentLinkedTableName)
tdfLinked.Connect = strBackendTargetDbPassword & ";DATABASE=" & strGetCurrentLinkedPath
tdfLinked.SourceTableName = strGetCurrentLinkedTableName
dbs.TableDefs.Append tdfLinked
End If
intTableCounter = intTableCounter + 1
If intNumberOfTables = intTableCounter Then
GoTo ClearDownArrays
End If
Next
Exit Function
ErrorDetected:
If Err.Number = 3031 Then
MsgBox "The password supplied with the function (ChangeTableDetails) " & vbCrLf & "is incorrect for the Backend Db." & vbCrLf & vbCrLf & _
"Please provide a valid password for Const 'strTargetDbPassword'", vbExclamation, "Invalid Password Set"
Else
MsgBox Err.Number & " - " & Err.Description, vbCritical, "Unexpected error detected, update aborted"
End If
ClearDownArrays:
Set tdf = Nothing
dbs.Close
Set dbs = Nothing
End Function
Public Function FindDatabasePathFr0mLinkedString(GetLinkedString As String) As String
Dim intStartPosition As Integer
Dim intEndPosition As Integer
On Error Resume Next
intStartPosition = InStr(1, GetLinkedString, "Database=") + 9
intEndPosition = InStr(1, GetLinkedString, ".mdb") + 4
FindDatabasePathFr0mLinkedString = MID(GetLinkedString, intStartPosition, intEndPosition)
End Function
