This is the code that is in a module:
Option Explicit
Public Const conAppTitle = "MyProgram"
Public Const DataMdb = "MyDat.mdb"
Public Const PgmMdb = "MyPgm.mdb"
Public Const SomeTable = "MyTableName"
Declare Function GetOpenFileName Lib "comdlg32.dll"
Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME)
As Boolean
Declare Function GetSaveFileName Lib "comdlg32.dll"
Alias "GetSaveFileNameA" (pOpenfilename As OPENFILENAME)
As Boolean
Type MSA_OPENFILENAME
strFilter As String
lngFilterIndex As Long
strInitialDir As String
strInitialFile As String
strDialogTitle As String
strDefaultExtension As String
lngFlags As Long
strFullPathReturned As String
strFileNameReturned As String
intFileOffset As Integer
intFileExtension As Integer
End Type
Const ALLFILES = "All Files"
Type OPENFILENAME
lStructSize As Long
hwndOwner As Long
hInstance As Long
lpstrFilter As String
lpstrCustomFilter As Long
nMaxCustrFilter As Long
nFilterIndex As Long
lpstrFile As String
nMaxFile As Long
lpstrFileTitle As String
nMaxFileTitle As Long
lpstrInitialDir As String
lpstrTitle As String
Flags As Long
nFileOffset As Integer
nFileExtension As Integer
lpstrDefExt As String
lCustrData As Long
lpfnHook As Long
lpTemplateName As Long
End Type
Const OFN_ALLOWMULTISELECT = &H200
Const OFN_CREATEPROMPT = &H2000
Const OFN_EXPLORER = &H80000
Const OFN_FILEMUSTEXIST = &H1000
Const OFN_HIDEREADONLY = &H4
Const OFN_NOCHANGEDIR = &H8
Const OFN_NODEREFERENCELINKS = &H100000
Const OFN_NONETWORKBUTTON = &H20000
Const OFN_NOREADONLYRETURN = &H8000
Const OFN_NOVALIDATE = &H100
Const OFN_OVERWRITEPROMPT = &H2
Const OFN_PATHMUSTEXIST = &H800
Const OFN_READONLY = &H1
Const OFN_SHOWHELP = &H10
Public Function CheckLinks() As Boolean 'Check links to
the DataMdb database; returns True if links are OK.
Dim dbs As Database, rst As Recordset
Set dbs = CurrentDb
'Open a linked table to see if connection information is
correct.
On Error Resume Next
Set rst = dbs.OpenRecordset("MPPTbl")
'If there's no error, return True.
If Err = 0 Then
CheckLinks = True
Else
CheckLinks = False
End If
End Function
Public Function RelinkTables() As Boolean
Dim strSearchPath As String, strFileName As String,
intError As Integer, strError As String
Const conMaxTables = 8
Const conNonExistentTable = 3011
Const conNotNorthwind = 3078
Const conNwindNotFound = 3024
Const conAccessDenied = 3051
Const conReadOnlyDatabase = 3027
Dim strPath As String
Dim strNewDB As String
'Look for the DataMdb database in the same folder.
strSearchPath = CurrentDb().Name
strSearchPath = Left$(strSearchPath, Len(strSearchPath) -
Len(Dir(strSearchPath)))
If (Dir(strSearchPath & DataMdb) <> "") Then
strFileName = strSearchPath & DataMdb
Else 'Can't find DataMdb, so display the Open dialog box.
MsgBox "Can't find linked tables in the " & DataMdb
& " database." & vbCrLf & _
"You must locate " & DataMdb & " in order to use " &
conAppTitle & ".", vbExclamation
strFileName = FindDatFile(strSearchPath)
If strFileName = "" Then
strError = "Sorry, you must locate " & DataMdb
& " to open " & conAppTitle & "."
GoTo Exit_Failed
End If
End If
'Fix the links.
If RefreshLinks(strFileName, strSearchPath) = True Then
RelinkTables = True
Exit Function
End If
' If it failed, display an error.
Select Case Err
Case conNonExistentTable, conNotNorthwind
strError = "File '" & strFileName & "does not contain
the required " & DataMdb & "tables."
Case Err = conNwindNotFound
strError = "You can't run " & conAppTitle & " until
you locate the " & DataMdb & " database."
Case Err = conAccessDenied
strError = "Couldn't open " & strFileName & " because
it is read-only or located on a read-only share."
Case Err = conReadOnlyDatabase
strError = "Can't relink tables because " &
conAppTitle & " is read-only or is located on a read-only
share."
Case Else
strError = Err.Description
End Select
Exit_Failed:
MsgBox strError, vbCritical
RelinkTables = False
End Function
Private Function RefreshLinks(strFileName As String,
strSearchPath As String) As Boolean
Dim dbs As Database, tdf As TableDef
Set dbs = CurrentDb()
For Each tdf In dbs.TableDefs
If Len(tdf.Connect) > 0 And (tdf.Attributes And
dbAttachedTable) Then
tdf.Connect = ";DATABASE=" & strFileName
Err = 0
On Error Resume Next
tdf.RefreshLink
If Err <> 0 Then
RefreshLinks = False
Exit Function
End If
End If
Next tdf
RefreshLinks = True
End Function
Function FindDatFile(strSearchPath) As String 'Displays
the Open dialog box for the user to locate the DataMdb
database. Returns the full path to it.
Dim msaof As MSA_OPENFILENAME
msaof.strDialogTitle = "Where Is " & DataMdb & "?"
msaof.strInitialDir = strSearchPath
msaof.strFilter = MSA_CreateFilterString
("Databases", "*.mdb")
MSA_GetOpenFileName msaof
FindDatFile = Trim(msaof.strFullPathReturned)
End Function
Function MSA_CreateFilterString(ParamArray varFilt() As
Variant) As String
Dim strFilter As String, intRet As Integer, intNum As
Integer
intNum = UBound(varFilt)
If (intNum <> -1) Then
For intRet = 0 To intNum
strFilter = strFilter & varFilt(intRet) & vbNullChar
Next
If intNum Mod 2 = 0 Then
strFilter = strFilter & "*.*" & vbNullChar
End If
strFilter = strFilter & vbNullChar
Else
strFilter = ""
End If
MSA_CreateFilterString = strFilter
End Function
Function MSA_ConvertFilterString(strFilterIn As String)
As String
Dim strFilter As String, intNum As Integer, intPos As
Integer, intLastPos As Integer
strFilter = ""
intNum = 0
intPos = 1
intLastPos = 1
Do
intPos = InStr(intLastPos, strFilterIn, "|")
If (intPos > intLastPos) Then
strFilter = strFilter & MID(strFilterIn,
intLastPos, intPos - intLastPos) & vbNullChar
intNum = intNum + 1
intLastPos = intPos + 1
ElseIf (intPos = intLastPos) Then
intLastPos = intPos + 1
End If
Loop Until (intPos = 0)
intPos = Len(strFilterIn)
If (intPos >= intLastPos) Then
strFilter = strFilter & MID(strFilterIn, intLastPos,
intPos - intLastPos + 1) & vbNullChar
intNum = intNum + 1
End If
If intNum Mod 2 = 1 Then
strFilter = strFilter & "*.*" & vbNullChar
End If
If strFilter <> "" Then
strFilter = strFilter & vbNullChar
End If
MSA_ConvertFilterString = strFilter
End Function
Private Function MSA_GetSaveFileName(msaof As
MSA_OPENFILENAME) As Integer
Dim of As OPENFILENAME, intRet As Integer
MSAOF_to_OF msaof, of
of.Flags = of.Flags Or OFN_HIDEREADONLY
intRet = GetSaveFileName(of)
If intRet Then
OF_to_MSAOF of, msaof
End If
MSA_GetSaveFileName = intRet
End Function
Function MSA_SimpleGetSaveFileName() As String
Dim msaof As MSA_OPENFILENAME, intRet As Integer, strRet
As String
intRet = MSA_GetSaveFileName(msaof)
If intRet Then
strRet = msaof.strFullPathReturned
End If
MSA_SimpleGetSaveFileName = strRet
End Function
Private Function MSA_GetOpenFileName(msaof As
MSA_OPENFILENAME) As Integer
Dim of As OPENFILENAME, intRet As Integer
MSAOF_to_OF msaof, of
intRet = GetOpenFileName(of)
If intRet Then
OF_to_MSAOF of, msaof
End If
MSA_GetOpenFileName = intRet
End Function
Function MSA_SimpleGetOpenFileName() As String
Dim msaof As MSA_OPENFILENAME, intRet As Integer, strRet
As String
intRet = MSA_GetOpenFileName(msaof)
If intRet Then
strRet = msaof.strFullPathReturned
End If
MSA_SimpleGetOpenFileName = strRet
End Function
Private Sub OF_to_MSAOF(of As OPENFILENAME, msaof As
MSA_OPENFILENAME) 'This sub converts from the Win32
structure to the Microsoft Access structure.
msaof.strFullPathReturned = Left(of.lpstrFile, InStr
(of.lpstrFile, vbNullChar) - 1)
msaof.strFileNameReturned = of.lpstrFileTitle
msaof.intFileOffset = of.nFileOffset
msaof.intFileExtension = of.nFileExtension
End Sub
Private Sub MSAOF_to_OF(msaof As MSA_OPENFILENAME, of As
OPENFILENAME) 'This sub converts from the Microsoft
Access structure to the Win32 structure.
Dim strFile As String * 512
of.hwndOwner = Application.hWndAccessApp
of.hInstance = 0
of.lpstrCustomFilter = 0
of.nMaxCustrFilter = 0
of.lpfnHook = 0
of.lpTemplateName = 0
of.lCustrData = 0
If msaof.strFilter = "" Then
of.lpstrFilter = MSA_CreateFilterString(ALLFILES)
Else
of.lpstrFilter = msaof.strFilter
End If
of.nFilterIndex = msaof.lngFilterIndex
of.lpstrFile = msaof.strInitialFile & String(512 - Len
(msaof.strInitialFile), 0)
of.nMaxFile = 511
of.lpstrFileTitle = String(512, 0)
of.nMaxFileTitle = 511
of.lpstrTitle = msaof.strDialogTitle
of.lpstrInitialDir = msaof.strInitialDir
of.lpstrDefExt = msaof.strDefaultExtension
of.Flags = msaof.lngFlags
of.lStructSize = Len(of)
End Sub
This is a code for the onload() on the app that starts up:
If CheckLinks() = False Then
If RelinkTables() = False Then
DoCmd.Close acForm, "Startup"
CloseCurrentDatabase
End If
End If
this is the error I get when I move the back end:
C:\and the path of db database for relink\backend is not
a valid path. make sure the path name is spelled
correctly and that you are connected to the server which
the file resides. ok or help
