This is the entire code for the connect to backend module..
Option Explicit ' Require variables to be declared before being used.
Option Compare Database ' Use database order for string comparisons.
Declare Function GetOpenFileName Lib "comdlg32.dll" Alias _
"GetOpenFileNameA" (pOpenfilename As OPENNAME) As Boolean
Declare Function GetSaveFileName Lib "comdlg32.dll" Alias _
"GetSaveFileNameA" (pOpenfilename As OPENNAME) 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 OPENNAME
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
Function FindBackEnd(strSearchPath) As String
' Displays the Open dialog box for the user to locate
' the DCA Expro backend database. Returns the full path to the data file
Dim msaof As MSA_OPENFILENAME
' Set options for the dialog box.
msaof.strDialogTitle = "Select Back End Database File to link..."
msaof.strInitialDir = strSearchPath
msaof.strFilter = MSA_CreateFilterString("Databases", "*.mdb")
' Call the Open dialog routine.
MSA_GetOpenFileName msaof
' Return the path and file name.
FindBackEnd = Trim(msaof.strFullPathReturned)
End Function
Function MSA_CreateFilterString(ParamArray varFilt() As Variant) As String
Dim strFilter As String
Dim intRet As Integer
Dim 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
Dim intNum As Integer, intPos As Integer, intLastPos As Integer
strFilter = ""
intNum = 0
intPos = 1
intLastPos = 1
' Add strings as long as we find bars.
' Ignore any empty strings (not allowed).
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)
' Get last string if it exists (assuming strFilterIn was not bar terminated).
intPos = Len(strFilterIn)
If (intPos >= intLastPos) Then
strFilter = strFilter & Mid(strFilterIn, intLastPos, intPos - intLastPos + 1) & vbNullChar
intNum = intNum + 1
End If
' Add *.* if there's no extension for the last string.
If intNum Mod 2 = 1 Then
strFilter = strFilter & "*.*" & vbNullChar
End If
' Add terminating NULL if we have any filter.
If strFilter <> "" Then
strFilter = strFilter & vbNullChar
End If
MSA_ConvertFilterString = strFilter
End Function
Private Function MSA_GetSaveFileName(msaof As MSA_OPENFILENAME) As Integer
' Opens the file save dialog.
Dim of As OPENNAME
Dim intRet As Integer
MSAOF_t
F 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
' Opens the file save dialog with default values.
Dim msaof As MSA_OPENFILENAME
Dim intRet As Integer
Dim 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
' Opens the Open dialog.
Dim of As OPENNAME
Dim intRet As Integer
MSAOF_t
F 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
' Opens the Open dialog with default values.
Dim msaof As MSA_OPENFILENAME
Dim intRet As Integer
Dim strRet As String
intRet = MSA_GetOpenFileName(msaof)
If intRet Then
strRet = msaof.strFullPathReturned
End If
MSA_SimpleGetOpenFileName = strRet
End Function
Public Function CheckLinks() As Boolean
' Check links to the Back End Database; returns True if links are OK.
Dim dbs As DAO.Database, rst As DAO.Recordset
Set dbs = CurrentDb
' Open linked table to see if connection information is correct.
On Error Resume Next
Set rst = dbs.OpenRecordset("Order Details")
' If there's no error, return True.
If err = 0 Then
CheckLinks = True
Else
CheckLinks = False
End If
End Function
Private Sub OF_to_MSAOF(of As OPENNAME, 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_t
F(msaof As MSA_OPENFILENAME, of As OPENNAME)
' This sub converts from the Microsoft Access structure to the Win32 structure.
Dim strFile As String * 512
' Initialize some parts of the structure.
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
Private Function RefreshLinks(strFileName As String) As Boolean
' Refresh links to the supplied database. Return True if successful.
Dim dbs As DAO.Database
Dim tdf As DAO.TableDef
' Loop through all tables in the database, 14 in total
Set dbs = CurrentDb
For Each tdf In dbs.TableDefs
' If the table has a connect string, it's a linked table.
If Len(tdf.Connect) > 0 Then
tdf.Connect = ";DATABASE=" & strFileName
err = 0
On Error Resume Next
tdf.RefreshLink ' Relink the table.
If err <> 0 Then
RefreshLinks = False
Exit Function
End If
End If
Next tdf
RefreshLinks = True ' Relinking complete.
End Function
Public Function RelinkTables() As Boolean
' Tries to refresh the links to the DCA Expro backend database.
' Returns True if successful.
Dim strAccDir As String
Dim strSearchPath As String
Dim strFileName As String
Dim intError As Integer
Dim strError As String
Const conMaxTables = 8
Const conNonExistentTable = 3011
Const conNotNorthwind = 3078
Const conNwindNotFound = 3024
Const conAccessDenied = 3051
Const conReadOnlyDatabase = 3027
Const conAppTitle = " ASSETSonTRACK"
DoCmd.OpenForm "frmLinkManager", , , , , acHidden
' Get name of directory where the Back End Database File is located.
strAccDir = Forms!frmLinkManager.FilePath
' Get the default database path.
If Forms!frmLinkManager.FilePath = "" Then
strSearchPath = strAccDir
Else
strSearchPath = strAccDir
End If
' Look for the Back End Database.
If (Dir(strSearchPath) <> "") Then
strFileName = strSearchPath
Else
' Can't find It, so display the Open dialog box.
If MsgBox(" Cannot locate the Paradigm Commercial Current Data File." & "Contact your System Administrator if you are unsure of the file location. Fenwick How (713) 392 3923" & Chr(13) & " Do you wish to locate the Data File now?", vbCritical + vbYesNo, " File Error") = vbYes Then
strFileName = FindBackEnd(strSearchPath)
Forms!frmLinkManager.FilePath = strFileName
If strFileName = "" Then
MsgBox "Sorry, you must locate the Data File to open Application.", , " Error"
GoTo Exit_Failed
End If
Else
MsgBox "The Data File must be connected." & Chr(13) & "The Application will now close.", vbCritical, " Error"
DoCmd.Quit
End If
End If
' Fix the links.
If RefreshLinks(strFileName) Then
RelinkTables = True
DoCmd.Close acForm, "frmLinkManager"
Exit Function
End If
' If it failed, display an error.
Select Case err
Case conNonExistentTable, conNotNorthwind
strError = "File '" & strFileName & "' does not contain the correct Data File."
Case err = conNwindNotFound
strError = "You can't run " & conAppTitle & " until you locate the Data File."
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 = "An Error has occurred locating the Data File."
End Select
Exit_Failed:
MsgBox strError, , " Error"
strFileName = FindBackEnd(strSearchPath)
If strFileName = "" Then
MsgBox "No File selected, Database not Updated.", , " Error"
DoCmd.Close acForm, "frmLinkManager"
DoCmd.Quit
Exit Function
Else
Forms!frmLinkManager.FilePath = strFileName
Call RelinkTables
End If
RelinkTables = False
DoCmd.Close acForm, "frmLinkManager"
End Function
