Option Compare Database
Option Explicit
Function GetList(Fld As Control, ID As Variant, row As Variant, col As Variant, Code As Variant) As Variant
Dim dbs As Database, tdf As TableDef
Dim varFld As Variant, varReturnVal As Variant, n As Integer
Static intEntries As Integer
Static aData() As Variant
Select Case Code
Case acLBInitialize
Set dbs = CurrentDb
intEntries = dbs.TableDefs.Count
ReDim aData(intEntries, 2)
For Each tdf In dbs.TableDefs
If Len(tdf.Connect) = 0 Then
intEntries = intEntries - 1
Else
On Error Resume Next
varFld = tdf.Fields(0).Name
If Err <> 0 Then
Err.Clear
aData(n, 1) = "Broken"
Else
aData(n, 1) = "OK"
End If
On Error GoTo 0
aData(n, 0) = tdf.Name
aData(n, 2) = tdf.Connect
n = n + 1
End If
Next tdf
varReturnVal = True
Case acLBOpen
varReturnVal = Timer
Case acLBGetRowCount
varReturnVal = intEntries
Case acLBGetColumnCount
varReturnVal = 3
Case acLBGetColumnWidth
varReturnVal = -1
Case acLBGetValue
varReturnVal = aData(row, col)
Case acLBEnd
CleanUp:
Erase aData
End Select
GetList = varReturnVal
End Function
Private Sub BrowseButton_Click()
On Error GoTo Err_Handler
Dim strFullPath As String, strFolder As String, strFile As String
Dim intLength As Integer, intCount As Integer
strFullPath = BrowseFile("Access Databases", "accdb")
If strFullPath = "" Then Exit Sub
' Loop backwards through selected full path
' until backslash encountered
intLength = Len(strFullPath)
For intCount = intLength To 0 Step -1
If Mid(strFullPath, intCount, 1) = "\" Then
' Store folder and file names in variables
strFolder = Left(strFullPath, intCount - 1)
strFile = Mid(strFullPath, intCount + 1)
Exit For
End If
Next intCount
' Populate text boxes on form
Me!PathToSource = strFolder
Me!DbFile = strFile
Exit_Here:
Exit Sub
Err_Handler:
MsgBox Err.Description
Resume Exit_Here
End Sub
Private Sub CloseAppButton_Click()
On Error GoTo Err_CloseAppButton_Click
Application.CloseCurrentDatabase
Exit_CloseAppButton_Click:
Exit Sub
Err_CloseAppButton_Click:
MsgBox Err.Description
Resume Exit_CloseAppButton_Click
End Sub
Private Sub OKButton_Click()
On Error GoTo Err_OKButton_Click
Const conTITLE = "Refresh Links"
Const conINVALIDPATH = 3044
Const conMISSINGSPEC = 3625
Dim dbs As Database
Dim tdf As TableDef
Dim varItem As Variant
Dim strMessage As String, strDatabaseName As String
Dim strPath As String, strTable As String, strDbType As String
Dim intPathLength As Integer
Set dbs = CurrentDb()
' get path to back end database from text boxes
strDatabaseName = PathToSource & "\" & DbFile
' Ensure path to back end database has been entered
' Ensure path to back end database has been entered
If IsNull(PathToSource) Then
MsgBox "Path to source database must be " & _
"entered before updating links", vbInformation, conTITLE
Exit Sub
Else
If IsNull(DbFile) Then
MsgBox "File name must be " & _
"entered before updating links", vbInformation, conTITLE
Exit Sub
End If
End If
strMessage = "Are you sure you wish to link to " & _
strDatabaseName & " as the source database?"
' If link not confirmed abort procedure
If MsgBox(strMessage, vbOKCancel + vbQuestion, conTITLE) = vbCancel Then
Exit Sub
End If
' Check that source database exists
If Dir(strDatabaseName) = "" Then
MsgBox "The database you have specified as the " & _
"source was not found.", vbInformation, conTITLE
Exit Sub
End If
' Show hourglass
DoCmd.Hourglass True
' Loop through selected items and refresh link to each table
For Each varItem In lstTables.ItemsSelected
strTable = lstTables.ItemData(varItem)
Set tdf = dbs.TableDefs(strTable)
strDbType = Left$(tdf.Connect, InStr(tdf.Connect, "DATABASE=") + 8)
tdf.Connect = strDbType & strDatabaseName
tdf.RefreshLink
Next varItem
' Hide hourglass
DoCmd.Hourglass False
MsgBox "Linking completed.", vbInformation, conTITLE
Exit_OKButton_Click:
DoCmd.Hourglass False
Me!lstTables.Requery
Set tdf = Nothing
Set dbs = Nothing
Exit Sub
Err_OKButton_Click:
Select Case Err.Number
Case conINVALIDPATH
strPath = Left$(strDatabaseName, Len(strDatabaseName) - Len(Dir(strDatabaseName)) - 1)
tdf.Connect = strDbType & strPath
Resume
Case conMISSINGSPEC
DoCmd.Hourglass False
strMessage = "No specification exists for " & tdf.Name & "." & _
vbNewLine & vbNewLine & "Click OK to rebuild the link."
dbs.TableDefs.Delete (tdf.Name)
MsgBox strMessage, vbInformation, "Error"
RunCommand acCmdLinkTables
DoCmd.Hourglass True
Resume Next
Case Else
DoCmd.Hourglass False
MsgBox Err.Description & " (" & Err.Number & ")"
Resume Exit_OKButton_Click
End Select
End Sub
Private Sub CloseButton_Click()
On Error GoTo Err_CloseButton_Click
DoCmd.Close
Exit_CloseButton_Click:
Exit Sub
Err_CloseButton_Click:
MsgBox Err.Description
Resume Exit_CloseButton_Click
End Sub