Private Function fLinkIsValid(strTable As String) As Boolean
Dim var As Variant
On Error Resume Next
var = mdb.TableDefs(strTable).Fields(0).Name
If Err <> 0 Then
fLinkIsValid = False
Else
fLinkIsValid = True
End If
On Error GoTo 0
End Function
Private Function strDBDir() As String
On Error GoTo strDBDir_Err
Static strDbName As String
If strDbName = "" Then
strDbName = mdb.Name
Do While Right$(strDbName, 1) <> "\"
strDbName = Left$(strDbName, Len(strDbName) - 1)
Loop
End If
strDBDir = UCase$(strDbName)
strDBDir_End:
On Error GoTo 0
Exit Function
strDBDir_Err:
Beep
MsgBox Err.Description, , "Error: " & Err.Number _
& " in function basTableLinks.strDBDir"
Resume strDBDir_End
End Function
Private Function strGetLinkFromCache() As String
On Error GoTo strGetLinkFromCache_Err
Dim strLink As String
Dim I As Integer
strLink = Mid$(mtbl.Connect, InStr(mtbl.Connect, ";DATABASE=") + 10)
For I = 0 To UBound(mastrOldLinks)
If mastrOldLinks(I) = strLink Then
strGetLinkFromCache = mastrNewLinks(I)
Exit For
End If
Next
strGetLinkFromCache_End:
mfLinkFromUser = False
On Error GoTo 0
Exit Function
strGetLinkFromCache_Err:
Beep
MsgBox Err.Description, , "Error: " & Err.Number _
& " in function basTableLinks.strGetLinkFromCache"
Resume strGetLinkFromCache_End
End Function
Private Function strGetLinkFromUser() As String
On Error GoTo strGetLinkFromUser_Err
Static fNotFirst As Boolean
Dim strMsg As String
Dim strLink As String
Dim strFilter As String
Dim lngflags As Long
Dim varNewLink As Variant
strLink = Mid$(mtbl.Connect, InStr(mtbl.Connect, ";DATABASE=") + 10)
strMsg = "New location of " & mtbl.SourceTableName & "?"
If fLinkIsFile() Then
strMsg = strMsg & " (WAS file """ & strLink & """)"
If Left$(mtbl.Connect, 10) = ";DATABASE=" Then ' Access database
strFilter = "Access (*.mdb)" & vbNullChar & "*.mdb" _
& vbNullChar & "All Files (*.*)" & vbNullChar & "*.*"
lngflags = tscFNHideReadOnly Or tscFNLongNames
varNewLink = tsGetFileFromUser( _
strInitialDir:=IIf(fNotFirst, "", strDBDir()), _
strFilter:=strFilter, _
rlngflags:=lngflags, _
strDialogTitle:=strMsg)
Else ' Non-Access database
strFilter = "All Files (*.*)" & vbNullChar & "*.*" _
& vbNullChar & "Excel (*.xl?)" & vbNullChar & "*.xl?" _
& vbNullChar & "HTML (*.htm?)" & vbNullChar & "*.htm?"
lngflags = tscFNHideReadOnly Or tscFNLongNames
varNewLink = tsGetFileFromUser( _
strInitialDir:=IIf(fNotFirst, "", strDBDir()), _
strFilter:=strFilter, _
rlngflags:=lngflags, _
strDialogTitle:=strMsg)
End If
Else
strMsg = strMsg & vbCrLf & "(WAS folder """ & strLink & """)"
varNewLink = tsGetPathFromUser(strHeaderMsg:=strMsg)
End If
If IsNull(varNewLink) Then
strGetLinkFromUser = ""
Else
strGetLinkFromUser = varNewLink
End If
strGetLinkFromUser_End:
fNotFirst = True
mfLinkFromUser = True
On Error GoTo 0
Exit Function
strGetLinkFromUser_Err:
Beep
MsgBox Err.Description, , "Error: " & Err.Number _
& " in function basTableLinks.strGetLinkFromUser"
Resume strGetLinkFromUser_End
End Function
Private Function fChangeLink(strNewLink) As Boolean
On Error Resume Next
Dim varPassword As Variant
Dim strOldLink As String
Dim strOldConnect As String
Dim intErrorType As Integer
Const intcCantFindTable As Integer = 1
Const intcOtherError As Integer = 2
strOldConnect = mtbl.Connect
If strNewLink <> "" Then
strOldLink = tsstrGetItem("DATABASE", mtbl.Connect)
mtbl.Connect = tsstrSetItem("DATABASE", strNewLink, mtbl.Connect)
mtbl.RefreshLink
Select Case Err
Case 0
GoTo fChangeLinkSuccess
Case ecInvalidPassword
mtbl.Connect = tsstrRemoveItem("PWD", mtbl.Connect)
For Each varPassword In mcolPasswords
mtbl.Connect = tsstrSetItem("PWD", varPassword, _
mtbl.Connect, , True)
mtbl.RefreshLink
Select Case Err
Case 0
GoTo fChangeLinkSuccess
Case ecInvalidPassword
Case ecCantFindObject
intErrorType = intcCantFindTable
GoTo fChangeLinkFailure
Case Else
intErrorType = intcOtherError
GoTo fChangeLinkFailure
End Select
Next
DoCmd.OpenForm strcPasswordForm, , , , , acDialog, _
strFileName(strNewLink)
Do While IsFormLoaded(strcPasswordForm)
mtbl.Connect = tsstrSetItem("PWD", _
Forms(strcPasswordForm).txtPWD, mtbl.Connect, , True)
mtbl.RefreshLink
Select Case Err
Case 0
mcolPasswords.Add Forms(strcPasswordForm).txtPWD
GoTo fChangeLinkSuccess
Case ecInvalidPassword
Beep
MsgBox "The password you entered is not valid.", _
vbOKOnly + vbExclamation, "Invalid Password"
Case ecCantFindObject
intErrorType = intcCantFindTable
GoTo fChangeLinkFailure
Case Else
intErrorType = intcOtherError
GoTo fChangeLinkFailure
End Select
DoCmd.Close acForm, strcPasswordForm
DoCmd.OpenForm strcPasswordForm, , , , , acDialog, _
strFileName(strNewLink)
Loop
Case ecCantFindObject
intErrorType = intcCantFindTable
GoTo fChangeLinkFailure
Case Else
intErrorType = intcOtherError
GoTo fChangeLinkFailure
End Select
End If
fChangeLinkFailure:
fChangeLink = False
mtbl.Connect = strOldConnect
If mfLinkFromUser Then
Select Case intErrorType
Case intcCantFindTable
Beep
MsgBox "Can not find table """ & mtbl.SourceTableName _
& """ in this database.", , "Change Link Error"
Case intcOtherError
Beep
MsgBox "Can not link to table """ & mtbl.SourceTableName _
& """ in database """ & strNewLink & """.@@" _
& Err.Description, , "Change Link Error " & Err.Number
Case Else
End Select
End If
GoTo fChangeLink_End
fChangeLinkSuccess:
fChangeLink = True
CacheLink strOldLink, strNewLink
LogResult "...Link Fixed " & "[NOW " & strNewLink & "]"
fChangeLink_End:
DoCmd.Close acForm, strcPasswordForm
On Error GoTo 0
End Function
Private Sub CacheLink(ByVal strOldLink As String, ByVal strNewLink As String)
On Error GoTo CacheLink_Err
Dim I As Integer
For I = 0 To UBound(mastrOldLinks)
If mastrOldLinks(I) = strOldLink Then
mastrNewLinks(I) = strNewLink
Exit Sub
ElseIf mastrOldLinks(I) = "" Then
Exit For
End If
Next
If I > UBound(mastrOldLinks) Then
ReDim Preserve mastrOldLinks(I)
ReDim Preserve mastrNewLinks(I)
End If
mastrOldLinks(I) = strOldLink
mastrNewLinks(I) = strNewLink
CacheLink_End:
On Error GoTo 0
Exit Sub
CacheLink_Err:
Beep
MsgBox Err.Description, , "Error: " & Err.Number _
& " in sub basTableLinks.CacheLink"
Resume CacheLink_End
End Sub
Private Function fLinkIsFile() As Boolean
On Error GoTo fLinkIsFile_Err
Dim strConnect As String
Dim I As Integer
strConnect = mtbl.Connect
If Left$(strConnect, 10) = ";Database=" Then
fLinkIsFile = True
ElseIf Left$(strConnect, 5) = "Excel" Then
fLinkIsFile = True
ElseIf Left$(strConnect, 4) = "HTML" Then
fLinkIsFile = True
ElseIf Left$(strConnect, 4) = "Text" Then
fLinkIsFile = False
ElseIf Left$(strConnect, 4) = "dBase" Then
fLinkIsFile = False
ElseIf Left$(strConnect, 7) = "Paradox" Then
fLinkIsFile = False
Else
For I = Len(strConnect) To 1 Step -1
If Mid$(strConnect, I, 1) = "." Then
fLinkIsFile = True
Exit For
ElseIf Mid$(strConnect, I, 1) = "\" Then
fLinkIsFile = False
Exit For
End If
Next
End If
fLinkIsFile_End:
On Error GoTo 0
Exit Function
fLinkIsFile_Err:
Beep
MsgBox Err.Description, , "Error: " & Err.Number _
& " in function basTableLinks.fLinkIsFile"
Resume fLinkIsFile_End
End Function
Private Sub SetRunOnce(ByRef rvarSetting As Boolean)
On Error GoTo SetRunOnce_Err
Dim prp As Property
mdb.Properties(mstrcRunOncePropertyName) = rvarSetting
mdb.Properties.Refresh
SetRunOnce_End:
On Error GoTo 0
Exit Sub
SetRunOnce_Err:
Select Case Err.Number
Case ecPropNotFound
Set prp = mdb.CreateProperty(mstrcRunOncePropertyName, _
dbBoolean, rvarSetting)
mdb.Properties.Append prp
mdb.Properties.Refresh
Set prp = Nothing
Resume SetRunOnce_End
Case Else
Beep
MsgBox Err.Description, , "Error: " & Err.Number _
& " in function basTableLinks.Set_tsTableLinkerRunOnce"
Resume SetRunOnce_End
End Select
End Sub
Private Function fGetRunOnce() As Boolean
On Error Resume Next
fGetRunOnce = mdb.Properties(mstrcRunOncePropertyName)
If Err <> 0 Then fGetRunOnce = False
On Error GoTo 0
End Function
Private Sub LogProcess(ByRef rstrMsg As String)
If mfDebug Then Debug.Print rstrMsg;
If mstrLogFile <> "" Then mstrLog = mstrLog & rstrMsg
End Sub
Private Sub LogResult(ByRef rstrMsg As String)
If mfDebug Then Debug.Print rstrMsg
If mstrLogFile <> "" Then mstrLog = mstrLog & rstrMsg & vbCrLf
End Sub
Private Sub WriteLogFile()
On Error GoTo WriteLogFile_Err
Dim intFile As Integer
If mstrLogFile <> "" Then
intFile = FreeFile
Open mstrLogFile For Output As intFile
Print #intFile, mstrLog
End If
WriteLogFile_End:
On Error Resume Next
Close #intFile
On Error GoTo 0
Exit Sub
WriteLogFile_Err:
Resume WriteLogFile_End
End Sub
Public Sub tsDumpLinks(Optional fShowFullConnectStrings As Boolean = True)
On Error GoTo tsDumpLinks_Err
Set mdb = CurrentDb
Debug.Print
Debug.Print "LINKED TABLES:"
Debug.Print "----------------------------------"
Debug.Print "LocalName SourceTableName LinkStatus"
If fShowFullConnectStrings Then
Debug.Print "Full Connect String"
Else
Debug.Print "Link"
End If
Debug.Print "----------------------------------"
Debug.Print
For Each mtbl In CurrentDb.TableDefs
If InStr(mtbl.Connect, ";DATABASE=") <> 0 Then
Debug.Print mtbl.Name; Tab(21); mtbl.SourceTableName; Tab(41); _
IIf(fLinkIsValid(mtbl.Name), "[OK]", "[MISSING]")
If fShowFullConnectStrings Then
Debug.Print mtbl.Connect
Else
Debug.Print tsstrGetItem("DATABASE", mtbl.Connect)
End If
Debug.Print
End If
Next
tsDumpLinks_End:
On Error Resume Next
Set mdb = Nothing
On Error GoTo 0
Exit Sub
tsDumpLinks_Err:
Beep
MsgBox Err.Description, , "Error: " & Err.Number _
& " in sub basTableLinks.tsDumpLinks"
Resume tsDumpLinks_End
End Sub
