Environment: Windows Server, Access/VBA, Microsoft SQL Server
Description: This code module links database tables to the MS Access database file, and is part of the OneCard system. The tables names and access information are stored in local tables, including production and test access. MS Access requires tables to be mapped for use with forms, queries or reports. Note that the same access information is also used for ODBC-less access. Use within Immediate Window: call linktables("PROD")
Features:
- Quick and easy way to move between test and production data sets
- Table driven, easy to add and remove references
- Connection for test and production databases is table driven
Sample Data:
Code:
Option Compare Database
Option Explicit
' basLinkTables
Dim strName As String
Dim strMessage As String
Dim strSQL As String
Dim intStatus As Integer
Dim strConnect As String ' Connect string
Const conNoMessage = "?"
Public Sub LinkTables(strDBname As String)
' Link data tables
' Name Description
' DBname Passed DB name set: PROD, TEST
' 27-JUL-2001 Robert Lawson
' 03-Jan-2008 Robert Lawson Rewrote
strName = "LinkTables"
On Error GoTo ErrorBegin
' System
Dim objConn As ADODB.Connection
Dim objRS As ADODB.Recordset, objRS2 As ADODB.Recordset, objRS3 As ADODB.Recordset
Dim strFile As String
' Local
Dim intStatus As Integer
Dim strSource As String, strdbConn As String
Dim strDatabase As String, strServer As String, strConn As String
Dim strTableName As String, strLinkName As String
strMessage = conNoMessage
Set objConn = CurrentProject.Connection
' ============================================
Debug.Print "01. Check if passed DB OK"
' ============================================
If Len(Trim(Nz(strDBname, ""))) = 0 Then
MsgBox "ERR: No databse passed"
GoTo ExitBegin
End If
strSQL = "SELECT * FROM SysDBConn WHERE DBName = '" & strDBname & "'"
Debug.Print strSQL
Set objRS = CreateObject("ADODB.Recordset")
objRS.Open strSQL, objConn, adOpenDynamic, adLockReadOnly ' read access
With objRS
If (.EOF Or .BOF) Then
MsgBox "ERR: Invalid databse passed"
GoTo ExitBegin
End If
End With
Set objRS = Nothing
' ============================================
Debug.Print "02. Remove existing links"
' ============================================
Call RemoveLinks(intStatus)
If intStatus <> 0 Then
GoTo ExitBegin
End If
' ============================================
Debug.Print "03. Link Tables"
' ============================================
strSQL = "SELECT * FROM SysDBConn WHERE DBName = '" & strDBname & "'"
Debug.Print strSQL
Set objRS = CreateObject("ADODB.Recordset")
objRS.Open strSQL, objConn, adOpenDynamic, adLockReadOnly ' read access
With objRS
Do Until .EOF
strSource = objRS!Source
strServer = objRS!SERVER
strDatabase = objRS!Database
strConn = objRS!ConnLink
' ODBC;DRIVER=SQL Server;SERVER=ServerName;DATABASE=DBname;Trusted_Connection=Yes
strdbConn = strConn & ";SERVER=" & strServer & ";DATABASE=" & strDatabase
strSQL = "SELECT * from SysTableLink WHERE SOURCE = """ & strSource & """"
Debug.Print strSQL
Set objRS2 = CreateObject("ADODB.Recordset")
objRS2.Open strSQL, objConn, adOpenDynamic, adLockReadOnly ' read access
Do Until objRS2.EOF
strTableName = objRS2!TableName
strLinkName = Nz(objRS2!LinkName, "")
Call LinkTable(strdbConn, strTableName, strLinkName, intStatus)
If intStatus <> 0 Then GoTo ExitBegin
objRS2.MoveNext
Loop
Set objRS2 = Nothing
.MoveNext
Loop
End With
Set objRS = Nothing
' ============================================
Debug.Print "04. Update SysInfo"
' ============================================
strSQL = "SELECT * FROM SysInfo"
Debug.Print strSQL
Set objRS = CreateObject("ADODB.Recordset")
objRS.Open strSQL, objConn, adOpenStatic, adLockPessimistic ' write access
With objRS
!DBname = strDBname
.Update
End With
Set objRS = Nothing
ExitBegin:
Debug.Print strName & " completed successfully for " & strDBname
Exit Sub
ErrorBegin:
MsgBox "Error in " & strName & " " & Err.Number & " " & Err.Description
GoTo ExitBegin
End Sub
Public Sub LinkTable(strDBsource As String, strTableName As String, strLinkName As String, intStatus As Integer)
' link table
' 04-JUL-2001 Robert Lawson Creation Date
' 03-Jan-2008 Robert Lawson Rewrote
' Name Description
' strDBsource Passed Source where table is
' strTableName Passed Table name
' strLinkName Passed Name to use to link table, if blank, use TableName
' intStatus Returned Status, 0=OK, <>0 you are not OK
'
strName = "LinkTable"
On Error GoTo ErrorBegin
Dim Db As Database
Dim tdf As TableDef
Dim strLinkedTableName As String
intStatus = 0 ' We've only just begun
Set Db = CurrentDb()
' Figure linked table name
If Len(Trim(strLinkName)) = 0 Then
strLinkedTableName = strTableName
Else
strLinkedTableName = strLinkName
End If
' Relink'em der logic
Set tdf = Db.CreateTableDef(strLinkedTableName)
With tdf
.Connect = strDBsource
.SourceTableName = strTableName
.Attributes = dbAttachSavePWD
Debug.Print "Name: "; .Name
Debug.Print "Connect: "; .Connect
Debug.Print "SourceTableName:"; .SourceTableName
Debug.Print "Attributes:"; .Attributes
End With
Db.TableDefs.Append tdf
ExitBegin:
Exit Sub
ErrorBegin:
intStatus = -100
MsgBox "Error in " & ":" & strName & " " & Err.Number & " " & Err.Description
GoTo ExitBegin
End Sub
Public Sub RemoveLinks(intStatus As Integer)
' Remove all links
'
' 01-Jan-2008 Robert Lawson Creation Date
' Name Description
' intStatus Returned Status, 0=OK, <>0 you are not OK
strName = "RemoveLinks"
On Error GoTo ErrorBegin
Dim Db As Database
Dim tdf As TableDef
Dim strLinkedTableName As String, strConn As String
intStatus = 0 ' We've only just begun
Set Db = CurrentDb()
For Each tdf In Db.TableDefs
strLinkedTableName = tdf.Name
strConn = Nz(tdf.Connect, "")
If Left(strLinkedTableName, 4) <> "MSys" Then
Debug.Print "Name: " & strLinkedTableName
Debug.Print "SourceTableName: " & tdf.SourceTableName
Debug.Print "Connect: " & tdf.Connect
Debug.Print "Attributes = " & tdf.Attributes
If Len(Trim(strConn)) > 0 Then
Debug.Print "Removing link for: " & strLinkedTableName
DoCmd.DeleteObject acTable, strLinkedTableName
End If
End If
Next
ExitBegin:
Exit Sub
ErrorBegin:
intStatus = -100
MsgBox "Error in " & ":" & strName & " " & Err.Number & " " & Err.Description
GoTo ExitBegin
End Sub
No comments:
Post a Comment