I am using code provided by Mr. Steele that allows for my MDB to
dynamically connect to remote SQL server databases. The code works
fine as follows:
Type TableDetails
TableName As String
SourceTableName As String
Attributes As Long
IndexSQL As String
End Type
Sub FixConnections(ServerName As String, DatabaseName As String)
' This code was originally written by
' Doug Steele, MVP dj******@canada.com
' 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.
' This specific routine connects to the specified SQL
Server
' database on a specified server. It assumes trusted
connection.
'
' Inputs: ServerName: Name of the SQL Server server (string)
' DatabaseName: Name of the database on that server
(string)
'
On Error GoTo Err_FixConnections
Dim dbCurrent As DAO.Database
Dim intLoop As Integer
Dim intToChange As Integer
Dim tdfCurrent As DAO.TableDef
Dim typNewTables() As TableDetails
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
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)
intToChange = intToChange + 1
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
'Press Ctrl G and type in -->> FixConnections "fulms255\fulmfg",
"ABBAccuray"
Set tdfCurrent =
dbCurrent.CreateTableDef(typNewTables(intLoop).Tab leName)
tdfCurrent.Connect = "ODBC;Driver={SQL Server}" & _
";Server=" & ServerName & _
";Database=" & DatabaseName & _
";Uid=no3pm;Pwd=dmacs"
tdfCurrent.SourceTableName = typNewTables(intLoop).SourceTableName
dbCurrent.TableDefs.Append tdfCurrent
' 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
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.
If Err.Number = 3291 Then
MsgBox "Problem creating the Index using" & vbCrLf & _
typNewTables(intLoop).IndexSQL, _
vbOKOnly + vbCritical, "Fix Connections"
Else
MsgBox Err.Description & " (" & Err.Number & ") encountered", _
vbOKOnly + vbCritical, "Fix Connections"
End If
Resume End_FixConnections
End Sub
Function GenerateIndexSQL(TableName As String) As String
' This code was originally written by
' Doug Steele, MVP dj******@canada.com
' 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
As you can see from the above the code requires you to supply your
server name and database.
Here's my problem:
I am attempting to connect to two different databases on the SAME
server. I want the code to be able to connect to both of these
databases. It was suggested to me that I create a table where I can
define the database, tablenames, etc. I have created a table called
tbl_DatabaseTables that has the following fields:
TableName
DatebaseName
Username
Password
ServerName
Within the table I defined the various tables, databases etc.
I am uncertain how I would need to modify this code so that the
tdfCurrent are looked up in the MDB table called tbl_DatabaseTables.
Can anyone help me with this ?
Thanks!!
