I have a number of databases in MS Access 97. Some tables in these
databases are linked to ODBC tables in Oracle9/10. We would like to
change the user name and password on the Oracle tables so each
database in MS Access linking to the tables in Oracle will need to be
relinked with the new credentials.
We would also like to automate this process of dropping the old links
and making a new one through a module that can be run in every
database. Piecing things together from various places on the internet,
this is what we have so far:
Option Compare Database
Option Explicit
'*********** Code Start ************
Const IntAttachedTableType As Integer = 4
Const ALLFILES = "All Files"
Function Replace(ByVal Valuein As String, ByVal WhatToReplace As _
String, ByVal Replacevalue As String) As String
Dim Temp As String, P As Long
Temp = Valuein
P = InStr(Temp, WhatToReplace)
Do While P 0
Temp = Left(Temp, P - 1) & Replacevalue & _
Mid(Temp, P + Len(WhatToReplace))
P = InStr(P + Len(Replacevalue), Temp, WhatToReplace, 1)
Loop
Replace = Temp
End Function
Function fRefreshLinks() As Boolean
Dim dbs As Database
Dim rst As Recordset, rstTry As Recordset
Dim tdf As TableDef
Dim strOldConnect As String, strNewConnect As String
Dim strFullLocation As String, strDatabase As String, strMsg As String
Dim objTableDef As TableDef
Dim strTableName As String
Dim strSourceTableName As String
Dim strNewConString As String
Set dbs = CurrentDb()
Set rst = dbs.OpenRecordset("SELECT MSysObjects.Connect,
MsysObjects.Database, " & _
"MSysObjects.Name from MSysObjects " & _
"WHERE MSysObjects.Type = " & IntAttachedTableType)
If rst.RecordCount <0 Then
rst.MoveFirst
Do
On Error Resume Next
Set rstTry = dbs.OpenRecordset(rst![Name].Value)
If Err = 1 Then
rstTry.Close
Set rstTry = Nothing
Else
On Error GoTo fRefreshLinks_Err
strFullLocation = rst.Name
strDatabase = FileName(strFullLocation)
Set tdf = dbs.TableDefs(rst![Name].Value)
strOldConnect = tdf.Connect
strNewConnect = strOldConnect
'strNewConnect = findConnect(strDatabase, tdf.Name, strOldConnect)
'If strNewConnect = "" Then
'Err.Raise
'Else
strTableName = tdf.Name
strSourceTableName = tdf.SourceTableName
strNewConString = rst("Connect")
strNewConString = Replace(strNewStr, "UID=XXX", "UID=XXX")
strNewConString = Replace(strNewStr, "PWD=XXX", "PWD=XXX")
Set objTableDef = New TableDef
With objTableDef
..Name = strTableName & "Temp"
..SourceTableName = strSourceTableName
..Connect = strNewConString
End With
CurrentDb.TableDefs.Append objTableDef
For Each tdf In dbs.TableDefs
If tdf.Connect = strOldConnect Then
tdf.Connect = strNewConnect
tdf.RefreshLink
End If
Next tdf
dbs.TableDefs.Refresh
'End If
End If
Err = 0
rst.MoveNext
If rst.EOF Then
Exit Do
End If
Loop
End If
fRefreshLinks_End:
Set tdf = Nothing
Set rst = Nothing
Set rstTry = Nothing
fRefreshLinks = True
Exit Function
fRefreshLinks_Err:
fRefreshLinks = False
Select Case Err
Case 3024:
Case Else:
strMsg = "Error Information..." & vbCrLf & vbCrLf
strMsg = strMsg & "Function: fRefreshLinks" & vbCrLf
strMsg = strMsg & "Description: " & Err.Description & vbCrLf
strMsg = strMsg & "Error #: " & Format$(Err.Number) & vbCrLf
MsgBox strMsg, vbOKOnly + vbCritical, "Error"
End Select
Exit Function
End Function
This will create a new link with the same name as the old one with
'temp' appended to the end of it. It should be identical in every
other way to the old link except with the updated username and
password in the connection string.
The trouble we are having is that it will not accept the new
connection string. In the line
strNewConString = rst("Connect")
we pull the old connection string from the recordset created from the
MSysObjects table. We could pull the old string from the tabledefs by
saying
strNewConString = tdf.Connect
instead and the code works flawlessly creating the new link, however
tdf.connect does not contain the username and password information
that MSysObjects does.
Is there something we have done wrong, or is there another way to
write the new connection string into the new tdf?
