I've automated my links to my DB2 db on my AS/400. Note that there is a local
table with:
ID AutoNumber Long Integer
LinkBackendDB Text 20
LinkDSNname Text 20
LinkLibName Text 20
LinkTableName Text 20
LinkIndexFields Text 100
LinkTableDesc Text 250
The code currently creates the link twice. Once without the "tbl" prefix, and
once with. (I originally started out working for several months before I
realaized that my links were the only objects without a prefix.)
Also, there is a progress bar, that comes with Access, that you need to select
for a form. I created two bars on the once form. One for "Overall", and
another for "Task".
Here's my code:
Option Compare Database
Option Explicit
Public db As Database, rs As Recordset, tdfAccess As TableDef, qdf As
QueryDef
Public intLinkODBCTables As Variant, intLinkDB2Tables As Variant
Public strLinkBackendDB As String, strLinkDSNname As String, strLinkLibName
As String
Public strLinkTableName As String, strLinkIndexFields As String,
strLinkTableDesc As String
Public intTablesToDelete As Variant, intTablesToCreate As Variant,
intTotalTables As Variant
Public intTTDeleteCntr As Variant, intTTCreateCntr As Variant,
intTotalTablesCntr As Variant
Public intPBTotalMax As Variant, intPBTaskMax As Variant
Public ctlProgBarOverall As String, ctlProgBarTask As String
Public intIsRemoteDB2dbOpen As Integer, prp As Property, newTable As Object
Public intCRPosition As Integer
Public strWhichPass As String, strCurrentUser As String, strPassword As
String
Public Function fncLinkODBCTables()
On Error GoTo Err_LinkODBCTables
' find out if this is an MDB or MDE file. If MDB, skip relinking
' If IsMDE(CurrentDb) Then
' MsgBox "This database is in MDE format...I will delete/recreate ODBC
links.", vbOKOnly + vbInformation
' perform this function
' Else
' MsgBox "This database is not in MDE format...I will SKIP
deleting/recreating links.", vbOKOnly + vbInformation
' Exit Function
' End If
DoCmd.Hourglass True
DoCmd.OpenForm "frmProgressBar"
Forms!frmProgressBar.Caption = "Refreshing ODBC Links...flushing old
links..."
DoEvents
' find out how many tables need to be deleted
Dim dbs As Database, tdf As TableDef, I As Integer
Set dbs = CurrentDb
intTablesToDelete = 0
For I = dbs.TableDefs.Count - 1 To 0 Step -1
Set tdf = dbs.TableDefs(I)
If (tdf.Attributes And dbAttachedODBC) Then
intTablesToDelete = intTablesToDelete + 1
End If
Next I
dbs.Close
Set dbs = Nothing
' MsgBox ("ODBC Links to delete...(" & intTablesToDelete & ")")
' find out how many links need to be created
Set db = CurrentDb
Set rs = db.OpenRecordset("tblODBCTables")
intTablesToCreate = 0
Do While Not rs.EOF
intTablesToCreate = intTablesToCreate + 1
rs.MoveNext
Loop
rs.Close
' MsgBox ("ODBC Links to create...(" & intTablesToCreate & ")")
intTotalTables = intTablesToDelete + intTablesToCreate
' MsgBox ("Total things to do...(" & intTotalTables & ")")
' setup the progress bar
' MsgBox ("About to setup the PB...")
If intTablesToDelete < 1 Then
intTablesToDelete = 0.1
End If
' MsgBox ("ODBC Links to delete..(" & intTablesToDelete & ")...create..(" &
intTablesToCreate & ")...total..(" & intTotalTables & ")")
Forms!frmProgressBar.ctlProgBarOverall.Max = intTotalTables
Forms!frmProgressBar.ctlProgBarTask.Max = intTablesToDelete
intTotalTablesCntr = 0
intTTDeleteCntr = 0
If intTotalTablesCntr <= intTotalTables Then
Forms!frmProgressBar.ctlProgBarOverall.Value = intTotalTablesCntr
End If
If intTTDeleteCntr <= intTablesToDelete Then
Forms!frmProgressBar.ctlProgBarTask.Value = intTTDeleteCntr
End If
DoEvents
' MsgBox ("Got past setting up the PB...")
' delete all the current ODBC links
Call fncDeleteODBCTableNames
' setup the progress bar
' MsgBox ("Setting up to read ODBCTables Table...")
If intTablesToCreate < 1 Then
intTablesToCreate = 1
End If
intTTCreateCntr = 0
Forms!frmProgressBar.ctlProgBarTask.Max = intTablesToCreate
DoEvents
strCurrentUser = Environ$("UserName")
strPassword = Environ$("Password")
' MsgBox ("The current user is: " & strCurrentUser)
' MsgBox ("The password is: " & strPassword)
' open and read the ODBC links table
Set db = CurrentDb
Set rs = db.OpenRecordset("tblODBCTables")
DoCmd.SetWarnings False
' get rid of the db logon window remnants
DoCmd.Close acForm, Forms!frmProgressBar.Name
DoEvents
DoCmd.OpenForm "frmProgressBar"
Forms!frmProgressBar.Caption = "Refreshing ODBC Links...recreating links..."
Forms!frmProgressBar.ctlProgBarOverall.Max = intTotalTables
Forms!frmProgressBar.ctlProgBarOverall.Value = intTotalTablesCntr
Forms!frmProgressBar.ctlProgBarTask.Max = intTablesToCreate
DoEvents
intIsRemoteDB2dbOpen = 0
Do While Not rs.EOF
' MsgBox ("About to link table...(" & rs![LinkLibName] & "." &
rs![LinkTableName] & ")...Desc..(" & rs![LinkTableDesc] & ")")
strLinkBackendDB = rs![LinkBackendDB]
strLinkDSNname = rs![LinkDSNname]
strLinkLibName = rs![LinkLibName]
strLinkTableName = rs![LinkTableName]
strLinkIndexFields = rs![LinkIndexFields]
intCRPosition = InStr(1, rs![LinkTableDesc], Chr$(13))
If intCRPosition < 1 Then
strLinkTableDesc = rs![LinkTableDesc]
Else
strLinkTableDesc = Left$(rs![LinkTableDesc], (intCRPosition - 1))
End If
' MsgBox ("In LinkODBC...BackendDB...(" & strLinkBackendDB &
")...DSNname...(" & strLinkDSNname & ")...Table..(" & strLinkLibName & "." &
strLinkTableName & ")...Index..(" & strLinkIndexFields & ")")
SysCmd acSysCmdSetStatus, ("Connecting to " & strLinkBackendDB & "...")
If rs![LinkBackendDB] = "DB2" Then
Call fncLinkDB2Table
End If
' update the progress bar
intTotalTablesCntr = intTotalTablesCntr + 1
intTTCreateCntr = intTTCreateCntr + 1
If intTotalTablesCntr <= intTotalTables Then
Forms!frmProgressBar.ctlProgBarOverall.Value = intTotalTablesCntr
End If
If intTTCreateCntr <= intTablesToCreate Then
Forms!frmProgressBar.ctlProgBarTask.Value = intTTCreateCntr
End If
DoEvents
TableNotInCollection:
rs.MoveNext
Loop
intLinkODBCTables = True
intLinkDB2Tables = True
Exit_LinkODBCTables:
On Error Resume Next
DoCmd.SetWarnings True
rs.Close
Set rs = Nothing
Set db = Nothing
SysCmd acSysCmdClearStatus
DoCmd.Hourglass False
' MsgBox ("Done creating links...going to close the Progress Bar")
' close progress bar
DoCmd.Close acForm, Forms!frmProgressBar.Name
Exit Function
Err_LinkODBCTables:
Select Case Err.Number
Case 3151
MsgBox ("There is an ODBC datasource problem." & vbCrLf & "Please verify
the DSN and database are spelled correctly." & vbCrLf & "Note: They can be case
sensitive.")
Case 3265, 3011, 7874 'item not in collection - table does not exist, or
can't find object
Resume TableNotInCollection
Case Else
MsgBox "Error # " & Err.Number & " was generated by " & Err.Source &
vbCrLf & Err.Description, , "LogOnCode - LinkODBCTables"
End Select
intLinkODBCTables = False
Resume Exit_LinkODBCTables
End Function
Public Function IsMDE(db As Database) As Boolean
On Error Resume Next
' It works on the fact that an MDE database has a property of "MDE" added with a
value of "T"
' This is far more reliable and less risky than checking the file extension or
attempting to access
' form or report design or VBA module code with an error handler.
'
' The use of the DAO Properties collection,
' For...Each...Next loop and On Error Resume Next handler
' gets around the problem of not having the property in an
' MDB database which otherwise causes run time errors.
Dim prp As Property
' assume it is not an MDE file.
IsMDE = False
For Each prp In db.Properties
If prp.Name = "MDE" Then
If prp.Value = "T" Then IsMDE = True
Exit For
End If
Next
End Function
Public Sub fncLinkDB2Table()
On Error GoTo Err_LinkDB2Tables
Dim dbODBC As Database, strConnect As String, strSQL As String
If strLinkDSNname = "" Then
MsgBox "You must supply a DSN in order to link tables."
Else
strConnect = "ODBC;DSN=" & strLinkDSNname & ";uid=" & strCurrentUser &
";mode=share;dbalias=" & strLinkDSNname & ";trusted_connection=1;;"
' strConnect = "ODBC;DSN=" & strLinkDSNname & ";mode=share;dbalias=" &
strLinkDSNname & ";trusted_connection=1;;"
End If
Set dbODBC = OpenDatabase("", False, False, strConnect)
DoCmd.SetWarnings False
' MsgBox ("Creating link for...BackendDB..(" & strLinkBackendDB &
")...DSNname..(" & strLinkDSNname & ")...Table..(" & strLinkLibName & "." &
strLinkTableName & ")...Index..(" & strLinkIndexFields & ")")
Set tdfAccess = db.CreateTableDef(strLinkLibName & "_" & strLinkTableName,
dbAttachSavePWD)
tdfAccess.Connect = dbODBC.Connect
tdfAccess.SourceTableName = strLinkLibName & "." & strLinkTableName
' write the record to the db
db.TableDefs.Append tdfAccess
' DoEvents
If strLinkTableDesc <> "*" Then
Call fncCreateTableDesc
End If
' run pseudo index queries here. If the table does not exist then this gets
skipped.
If strLinkIndexFields <> "*" Then
' MsgBox ("Creating Index for...BackendDB..(" & strLinkBackendDB &
")...DSNname..(" & strLinkDSNname & ")...Table..(" & strLinkLibName & "." &
strLinkTableName & ")...Index..(" & strLinkIndexFields & ")")
strSQL = "CREATE INDEX " & strLinkTableName & "Idx ON " & strLinkLibName &
"_" & strLinkTableName & " (" & strLinkIndexFields & ");"
DoCmd.RunSQL strSQL
End If
' ---------------------------------------------------------
' RENAME the new link with "tbl" prefix
'
DoCmd.Rename "tbl" & strLinkLibName & "_" & strLinkTableName, acTable,
strLinkLibName & "_" & strLinkTableName
DoEvents
' ---------------------------------------------------------
' create the OLD link for compatibility...TEMPORARILY (as of 07/02/04)
'
' MsgBox ("Creating link for...BackendDB..(" & strLinkBackendDB &
")...DSNname..(" & strLinkDSNname & ")...Table..(" & strLinkLibName & "." &
strLinkTableName & ")...Index..(" & strLinkIndexFields & ")")
Set tdfAccess = db.CreateTableDef(strLinkLibName & "_" & strLinkTableName,
dbAttachSavePWD)
tdfAccess.Connect = dbODBC.Connect
tdfAccess.SourceTableName = strLinkLibName & "." & strLinkTableName
' write the record to the db
db.TableDefs.Append tdfAccess
If strLinkTableDesc <> "*" Then
Call fncCreateTableDesc
End If
' run pseudo index queries here. If the table does not exist then this gets
skipped.
If strLinkIndexFields <> "*" Then
' MsgBox ("Creating Index for...BackendDB..(" & strLinkBackendDB &
")...DSNname..(" & strLinkDSNname & ")...Table..(" & strLinkLibName & "." &
strLinkTableName & ")...Index..(" & strLinkIndexFields & ")")
strSQL = "CREATE INDEX " & strLinkTableName & "Idx ON " & strLinkLibName &
"_" & strLinkTableName & " (" & strLinkIndexFields & ");"
DoCmd.RunSQL strSQL
End If
'
' this is the end of the TEMPORARY stuff
' ---------------------------------------------------------
DB2TableNotInCollection:
Exit_LinkDB2Tables:
On Error Resume Next
DoCmd.SetWarnings True
' Set dbODBC = Nothing
Exit Sub
Err_LinkDB2Tables:
Select Case Err.Number
Case 3151
MsgBox ("There is an ODBC datasource problem." & vbCrLf & "Please verify
the DSN and database are spelled correctly." & vbCrLf & "Note: They can be case
sensitive.")
Case 3265, 3011, 7874 'item not in collection - table does not exist, or
can't find object
Resume DB2TableNotInCollection
Case Else
MsgBox "Error # " & Err.Number & " was generated by " & Err.Source &
vbCrLf & Err.Description, , "LogOnCode - strLinkDB2Tables"
End Select
intLinkDB2Tables = False
Resume Exit_LinkDB2Tables
End Sub
'This procedure deletes all linked ODBC table names in an mdb.
Public Sub fncDeleteODBCTableNames()
On Error GoTo Err_DeleteODBCTableNames
' MsgBox ("Going to delete all ODBC linked tables...")
Dim dbs As Database, tdf As TableDef, I As Integer
Set dbs = CurrentDb
For I = dbs.TableDefs.Count - 1 To 0 Step -1
Set tdf = dbs.TableDefs(I)
If (tdf.Attributes And dbAttachedODBC) Then
dbs.TableDefs.Delete (tdf.Name)
' update the progress bar
intTotalTablesCntr = intTotalTablesCntr + 1
intTTDeleteCntr = intTTDeleteCntr + 1
If intTotalTablesCntr <= intTotalTables Then
Forms!frmProgressBar.ctlProgBarOverall.Value = intTotalTablesCntr
End If
If intTTDeleteCntr <= intTablesToDelete Then
Forms!frmProgressBar.ctlProgBarTask.Value = intTTDeleteCntr
End If
DoEvents
End If
Next I
' MsgBox ("All ODBC linked tables have been deleted...")
dbs.Close
Set dbs = Nothing
Exit_DeleteODBCTableNames:
Exit Sub
Err_DeleteODBCTableNames:
MsgBox ("Error # " & Str(Err.Number) & " was generated by " & Err.Source &
Chr(13) & Err.Description)
Resume Exit_DeleteODBCTableNames
End Sub
Private Sub fncCreateTableDesc()
On Error GoTo Err_CreateTableDesc
Dim prpNew As Property
Dim prpLoop As Property
With tdfAccess
' Create and append user-defined property.
Set prpNew = .CreateProperty()
prpNew.Name = "Description"
prpNew.Type = dbText
prpNew.Value = strLinkTableDesc
.Properties.Append prpNew
End With
Exit_CreateTableDesc:
On Error Resume Next
Exit Sub
Err_CreateTableDesc:
MsgBox "Error # " & Err.Number & " was generated by " & Err.Source & vbCrLf
& Err.Description, , "CreateTableDesc"
Resume Exit_CreateTableDesc
End Sub
HTH,
Tom
