Document Linked Tables
---
Hi Lior,
Here is code to document Linked tables with:
1. Table Description from source database (if linked table comes from
Access -- you may need to modify it for other types of links, I didn't
have any to test when I wrote this)
2. path and file to linked filename (works with Access and Excel)
put these 2 procedures in a general module. You can assign the function
directly to an event directly using (ie
=DocLinkTables(true, true)
to just run the procedure, run the Sub, RunDocLinkTables
click in the code and press F5
'~~~~~~~~~~~ Document Linked Tables ~~~~~~~~~~~
'--------------- RunDocLinkTables
Sub RunDocLinkTables()
'run this Sub if you don't have an event assigned to DocLinkTables
'to run, click in this code and press F5
DocLinkTables True, True
End Sub
'--------------- DocLinkTables
Function DocLinkTables( _
pBooDesc As Boolean, _
pBooLink As Boolean) As Boolean
'written by crystal
'strive4peace2006 at yahoo.com
'needs reference to
'Microsoft DAO Library
'modifies Description of each table with
'Description from source table if pBooDesc=true
'path of linked database if pBooLink=true
'adds to Description if it already exists
'anything after ~ is replaced
'USEAGE
'assign to an event
' --> =DocLinkTables(true, true)
On Error GoTo Proc_Err
DocLinkTables = False
Dim dbCurrent As dao.Database _
, dbLink As dao.Database _
, tdf As dao.TableDef _
, mProp As Property
Dim dbLinkName As String _
, dbLinkNameLast As String _
, mPos As Integer _
, numLinks As Integer _
, mMsg As String _
, mDesc As String
CurrentDb.TableDefs.Refresh
DoEvents
Set dbCurrent = CurrentDb
dbLinkName = ""
dbLinkNameLast = ""
numLinks = 0
For Each tdf In dbCurrent.TableDefs
SysCmd acSysCmdSetStatus, "Checking " & tdf.Name & "..."
mMsg = ""
'see if there is a connection string
If Len(tdf.Connect) > 1 Then
mPos = InStr(tdf.Connect, "Database=")
dbLinkName = Mid(tdf.Connect, mPos + 9)
If Left(tdf.Connect, 4) = "Text" Then
dbLinkName = dbLinkName & "\" & tdf.SourceTableName
End If
If pBooLink Then mMsg = dbLinkName
' make sure the file is valid
If Len(Dir(dbLinkName)) = 0 Then
mMsg = "Connection NOT VALID or no code to check --> " _
& mMsg
Else
Select Case True
'~~~ Access ~~~
Case Left(tdf.Connect, 10) = ";DATABASE="
' if this is the same database we just accessed,
' use same dbLink
If dbLinkName <> dbLinkNameLast Then
If dbLinkNameLast <> "" Then dbLink.Close
Set dbLink = OpenDatabase(dbLinkName)
dbLinkNameLast = dbLinkName
End If
If pBooDesc Then
On Error Resume Next
mMsg = Nz(dbLink.TableDefs( _
tdf.SourceTableName).Properties("Description") _
, "") & " ~" _
& mMsg
On Error GoTo Proc_Err
End If
'~~~ Excel ~~~
Case Left(tdf.Connect, 5) = "Excel"
mMsg = "Excel > " & mMsg
'~~~ Text ~~~
Case Left(tdf.Connect, 4) = "Text"
mMsg = "Text > " & mMsg
'~~~ Not Access or Excel ~~~
Case Else
MsgBox "No Code written to add more to -->" _
& tdf.Connect, , "Need to Add code"
End Select
End If
If Len(mMsg) = 0 Then mMsg = "Linked table"
If Len(mMsg) > 0 Then
On Error Resume Next
mDesc = Nz(tdf.Properties("Description"), "")
On Error GoTo Proc_Err
If InStr(mDesc, "~") > 0 Then
mDesc = Trim(Left(mDesc, InStr(mDesc, "~") - 1))
End If
mDesc = mDesc & " ~" & mMsg
With tdf
numLinks = numLinks + 1
On Error Resume Next
Set mProp = .CreateProperty("Description", dbText, mDesc)
.Properties.Append mProp
If Err.Number > 0 Then .Properties("Description") = mDesc
On Error GoTo Proc_Err
End With
End If
End If
Next tdf
CurrentDb.TableDefs.Refresh
DoEvents
DocLinkTables = True
MsgBox "Done Documenting Tables: " _
& numLinks & " Linked Table Descriptions changed" _
, , "Done Documenting Tables"
Proc_Exit:
On Error Resume Next
Set mProp = Nothing
Set tdf = Nothing
Set dbCurrent = Nothing
dbLink.Close
Set dbLink = Nothing
SysCmd acSysCmdClearStatus
Exit Function
Proc_Err:
MsgBox Err.Description, , _
"ERROR " & Err.Number & " DocLinkTables" _
& IIf(TypeName(tdf) <> "nothing", ": " & tdf.Name, "")
'press F8 to step through code and debug
'remove next line after debugged
Stop: Resume
Resume Proc_Exit
End Function
'~~~~~~~~~~~~~~~~~~~~~~~~~
Warm Regards,
Crystal
*
have an awesome day
*
MVP Access
Remote Programming and Training
strive4peace2006 at yahoo.com
*
