OK Spiff:
I've written relinker code a few times and I pulled this out of a sample. There is a function to see if a known linked table exists and then there is an API declare to get at the folder/file browse windows dialog (so you don't need some reference based wonky common controls installed). The line that checks:
If Len(tdf.Connect) Then
which by the way can be rewritten to make more sense:
If Len(tdf.Connect) > 0
I haven't got time at the moment to go through the exact implementation but the module below is one way in which I've done this. Note that I've opened a database variable against the database to be relinked. If you don't do this, if someone else already has the database open, the subsequent person to relink will find that the relink time takes many times longer.
Option Compare Database
Option Explicit
Private Declare Function GetOpenFileName Lib "comdlg32" Alias "GetOpenFileNameA" (FilNm As StrFileName) _
As Boolean
Private Type StrFileName
lngStructSize As Long
hwndOwner As Long
hInstance As Long
strFilter As String
strCustomFilter As String
intMaxCustFilter As Long
intFilterIndex As Long
strFile As String
intMaxFile As Long
strFileTitle As String
intMaxFileTitle As Long
strInitialDir As String
strTitle As String
lngflags As Long
intFileOffset As Integer
intFileExtension As Integer
strDefExt As String
lngCustData As Long
lngfnHook As Long
strTemplateName As String
End Type
Public Function GetFileName(Optional strInitDir As String, Optional strFilter As String = _
"All Files (*.*)" & vbNullChar & "*.*", Optional intFilterIndex As Integer = 1, _
Optional strDefaultExt As String = "", Optional StrFileName As String = "", Optional _
strDialogTitle As String = "", Optional fOpenFile As Boolean = True, Optional ByRef _
lngflags As Long = 0&) As Variant
'Gets Open file dialog and returns chosen file name
On Error GoTo errbail
Dim typFileName As StrFileName
Dim strFileTitle As String
Dim blnResult As Boolean
StrFileName = Left(StrFileName & String(256, 0), 256)
strFileTitle = String(256, 0)
With typFileName
.lngStructSize = Len(typFileName)
.hwndOwner = Application.hWndAccessApp
.strFilter = strFilter
.intFilterIndex = intFilterIndex
.strFile = StrFileName
.intMaxFile = Len(StrFileName)
.strFileTitle = strFileTitle
.intMaxFileTitle = Len(strFileTitle)
.strTitle = strDialogTitle
.lngflags = lngflags
.strDefExt = strDefaultExt
.strInitialDir = strInitDir
.hInstance = 0
.strCustomFilter = String(255, 0)
.intMaxCustFilter = 255
.lngfnHook = 0
End With
blnResult = GetOpenFileName(typFileName)
If blnResult Then
lngflags = typFileName.lngflags
GetFileName = TrimNull(typFileName.strFile)
Else
GetFileName = ""
End If
ExitErrBail:
Exit Function
errbail:
MsgBox Err.Description, , "Error: " & Err.Number _
& " in function modGetFiles.GetFile"
Resume ExitErrBail
End Function
Sub callrelink()
'assumption is that all linked tables are in one file. If not, modifications are required.
On Error GoTo ErrorHandler
Dim strDatabase As String
Dim db As DAO.Database
Dim tdf As TableDef
Set db = CurrentDb
For Each tdf In db.TableDefs
If Len(tdf.Connect) Then
strDatabase = Right$(tdf.Connect, Len(tdf.Connect) - 10)
If Len(Dir(strDatabase)) Then 'If len of return of Dir <> 0 then implicitly True _
BE is where expected so links should be good
MsgBox "links should be fine. Easy enough to skip this message. Note: This does not test if the table is in the BE. You need to either try to refresh the link or open a recordset that returns few or no records (WHERE PK = 0) and trap any error"
Exit For
Else
'Not found. So check to see if it is in the FE path and offer to link there
strDatabase = fnCurrentDBDir & fnLinkedFileName(strDatabase) 'Current Path & name of linked file without path
If Len(Dir(strDatabase)) Then 'check to see if BE is in FE path
If MsgBox("The data is not found. Do you wish to link to the file in the same location as the application", vbYesNo) = vbYes Then
If Relinker(strDatabase) = True Then
MsgBox "Relinked successfully"
Exit For
Else
MsgBox "Relink Failed"
Exit For
End If
Else
'Although BE is in FE path user wishes to browse for another version
MsgBox "You must find the BE database file named " & fnLinkedFileName(strDatabase)
strDatabase = GetFileName("C:\", "Access Databases (*.mdb)", 1, "mdb", "*.mdb", _
"Choose Database to Secure")
If Relinker(strDatabase) = True Then
MsgBox "Relinked successfully"
Exit For
Else
MsgBox "Relink Failed"
Exit For
End If
End If
Else
'BE is not in FE path or BE file name is changed or you don't want to use it if it's there so go find it
MsgBox "Data is not found. You must find the BE database file named " & fnLinkedFileName(strDatabase)
strDatabase = GetFileName("C:\", "Access Databases (*.mdb)", 1, "mdb", "*.mdb", _
"Choose Database to Secure")
If Relinker(strDatabase) = True Then
MsgBox "Relinked successfully"
Exit For
Else
MsgBox "Relink Failed"
Exit For
End If
End If
End If
End If
Next
ExitRoutine:
On Error Resume Next
Set tdf = Nothing
db.Close
Set db = Nothing
Exit Sub
ErrorHandler:
With Err
Select Case .Number
Case Else
MsgBox .Number & vbCrLf & .Description, vbInformation, "Error - Call to Relinker"
End Select
End With
'Resume 0
Resume ExitRoutine
End Sub
Function Relinker(strConnect As String) As Boolean
'mdb connect string begin with ;DATABASE, other BE files are different. This will only work
'with mdb files. You can modify the hardcoded line tdf.Conect = ";DATABASE=" & strConnect
On Error GoTo ErrorHandler
Dim dbCurr As DAO.Database
Dim dbLink As DAO.Database
Dim tdf As DAO.TableDef
Set dbLink = OpenDatabase(strConnect) 'needed for performance in multi user application
Set dbCurr = CurrentDb
For Each tdf In dbCurr.TableDefs
If Len(tdf.Connect) Then
tdf.Connect = ";DATABASE=" & strConnect
tdf.RefreshLink
End If
Next
Relinker = True
ExitRoutine:
On Error Resume Next
Set tdf = Nothing
dbCurr.Close
Set dbCurr = Nothing
dbLink.Close
Set dbLink = Nothing
Exit Function
ErrorHandler:
With Err
Select Case .Number
Case Else
MsgBox .Number & vbCrLf & .Description, vbInformation, "Error - Relinker"
End Select
End With
'Resume 0
Resume ExitRoutine
End Function
Private Function TrimNull(ByVal strItem As String) As String
On Error GoTo Err_TrimNull
Dim lngI As Long
lngI = InStr(strItem, vbNullChar)
If lngI > 0 Then
TrimNull = Left(strItem, lngI - 1)
Else
TrimNull = strItem
End If
Exit_TrimNull:
Exit Function
Err_TrimNull:
MsgBox Err.Description, , "Error: " & Err.Number _
& " in function modGetFiles.TrimNull"
Resume Exit_TrimNull
End Function
Function fnCurrentDBDir() As String
'returns path of the currently open application
Dim strDbPath As String
Dim strDBFile As String
strDbPath = CurrentDb.Name
strDBFile = Dir(strDbPath)
fnCurrentDBDir = Left(strDbPath, InStr(strDbPath, strDBFile) - 1)
End Function
Function fnLinkedFileName(strConnect As String) As String
'returns mdb file name by stripping of path etc
Dim lngPos As Long
lngPos = 1
lngPos = InStr(lngPos, strConnect, "\")
If lngPos > 0 Then
Do While InStr(lngPos, strConnect, "\")
lngPos = InStr(lngPos, strConnect, "\") + 1
Loop
fnLinkedFileName = Mid$(strConnect, lngPos)
End If
End Function
Ciao
Jürgen Welz
Edmonton AB Canada
[email protected]