how to control (and open) a find file dialog box

[Tarasque]

I need to open a find file dialog box to allow users to navigate to a different directory and select a file. The dialog box then needs to return the location of the file selected.

Does anyone know how to do this within VBA?

Many Thanks.

 

[GBall]

This is some old code that still works for me. I don't know if there's a better way to do it.

Option Compare Database
Option Explicit
Public gstrSecurity_Level As String
' Rem File/Open Dialog for 32 bit mode
' Hacked from Solutions.mdb by Trevor Best Dec 1997
' The functions to call are OpenFileNameDlg() and
' SaveFileNameDlg()

Declare Function GetOpenFileName Lib "comdlg32.dll" Alias _
"GetOpenFileNameA" (pOpenfilename As gtypOPENFILENAME) As Boolean
Declare Function GetSaveFileName Lib "comdlg32.dll" Alias _
"GetSaveFileNameA" (pOpenfilename As gtypOPENFILENAME) As Boolean

Type gtypMSA_OPENFILENAME
' Filter string used for the Open dialog filters.
' Use MSA_CreateFilterString() to create this.
' Default = All Files, *.*
strFilter As String
' Initial Filter to display.
' Default = 1.
lngFilterIndex As Long
' Initial directory for the dialog to open in.
' Default = Current working directory.
strInitialDir As String
' Initial file name to populate the dialog with.
' Default = "".
strInitialFile As String
strDialogTitle As String
' Default extension to append to file if user didn't specify one.
' Default = System Values (Open File, Save File).
strDefaultExtension As String
' Flags (see constant list) to be used.
' Default = no flags.
lngFlags As Long
' Full path of file picked. When the File Open dialog box is
' presented, if the user picks a nonexistent file,
' only the text in the "File Name" box is returned.
strFullPathReturned As String
' File name of file picked.
strFileNameReturned As String
' Offset in full path (strFullPathReturned) where the file name
' (strFileNameReturned) begins.
intFileOffset As Integer
' Offset in full path (strFullPathReturned) where the file extension begins.
intFileExtension As Integer
End Type

Const mALLFILES = "All Files"

Type gtypOPENFILENAME
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 mOFN_ALLOWMULTISELECT = &H200
Const mOFN_CREATEPROMPT = &H2000
Const mOFN_EXPLORER = &H80000
Const mOFN_FILEMUSTEXIST = &H1000
Const mOFN_HIDEREADONLY = &H4
Const mOFN_NOCHANGEDIR = &H8
Const mOFN_NODEREFERENCELINKS = &H100000
Const mOFN_NONETWORKBUTTON = &H20000
Const mOFN_NOREADONLYRETURN = &H8000
Const mOFN_NOVALIDATE = &H100
Const mOFN_OVERWRITEPROMPT = &H2
Const mOFN_PATHMUSTEXIST = &H800
Const mOFN_READONLY = &H1
Const mOFN_SHOWHELP = &H10

Function blnRefreshAndRelink() As Boolean
Dim dbsDbMyDB As Database
Dim tdfTblMyTableDef As TableDef
Dim strnewpath As String
Dim strNewConnect As String

On Error GoTo err_blnRefreshAndRelink

strnewpath = ""
' Set dbsDbMyDB = DBEngine(0)(0)
Set dbsDbMyDB = CurrentDb
' Loop through the TableDefs collection and refresh the links
' to non-ODBC linked tables.
For Each tdfTblMyTableDef In dbsDbMyDB.TableDefs
If strnewpath = "" Then
' First one only follows this route, but only if the link is bad !
' If is is good, i.e. we have already relinked this frontend once, then all
' linked tables will come through here.
If tdfTblMyTableDef.Attributes = dbAttachedTable Then
tdfTblMyTableDef.RefreshLink
'If this is still empty, then the first linked table has relinked with no
'problem. Therefore, we can assume that we are running with good links and
'not waste anymore time.
If strnewpath = "" Then
Exit For
End If
'Debug.Print tdfTblMyTableDef.Name
End If
Else
' We already have been pointed at the correct backend, so to save time
' and an abortive refreshlink for each table, establish the new link here.
' If there are multiple BEs, this should still work as the "on error" will
' drop into the same routine as before and ask to be pointed at the correct
' BE.
If tdfTblMyTableDef.Attributes = dbAttachedTable Then
strNewConnect = ";DATABASE=" & strnewpath
tdfTblMyTableDef.Connect = strNewConnect
tdfTblMyTableDef.RefreshLink
End If
End If
Next
blnRefreshAndRelink = True
Exit Function

err_blnRefreshAndRelink:
Select Case Err.Number
' Cannot find non-ODBC linked table file
Case 3024, 3044, 3043
' Check if a new path location has been set
If strnewpath = "" Then
MsgBox "The database location I have is incorrect. Please Click on OK and select the correct data file"
strnewpath = OpenFileNameDlg("Please Locate Data File", "Backend database|*_be.mdb", "C:\&quot
' If the Cancel command button is clicked, exit
If strnewpath = "" Then
MsgBox "No database selected - quitting application"
DoCmd.Quit
End If
End If
' Establish the new link.
strNewConnect = ";DATABASE=" & strnewpath
tdfTblMyTableDef.Connect = strNewConnect
tdfTblMyTableDef.RefreshLink
Resume Next
' Trap for unexpected errors.
Case Else
MsgBox Err.Description
blnRefreshAndRelink = False
End Select
End Function

Function OpenFileNameDlg(strPstrTitle As String, strPstrFilter As String, Optional strPstrInitialDir As String) As String
On Error GoTo PROC_ERR
' Get Open File Name, to be backward compatible with the
' Access 2.0 version that passed "title", "filter|spec" params
Dim strFilter As String

strFilter = CreateFilterString(strPstrFilter)

Dim msaof As gtypMSA_OPENFILENAME

' Set options for the dialog box.
msaof.strDialogTitle = strPstrTitle
msaof.strInitialDir = strPstrInitialDir
msaof.strFilter = strFilter 'MSA_CreateFilterString("Databases", "*.mdb&quot

' Call the Open dialog routine.
MSA_GetOpenFileName msaof

' Return the path and file name.
OpenFileNameDlg = Trim(msaof.strFullPathReturned)
Exit Function

PROC_ERR:
MsgBox "The following error occurred: " & Error$
Resume Next
End Function


Function SaveFileNameDlg(strPstrTitle As String, strPstrFilter As String, strPstrDefault As String) As String
On Error GoTo PROC_ERR
Dim msaof As gtypMSA_OPENFILENAME
Dim intRet As Integer
Dim strFilter As String

strFilter = CreateFilterString(strPstrFilter)

msaof.strFilter = strFilter
msaof.strDialogTitle = strPstrTitle
msaof.strInitialFile = strPstrDefault

intRet = MSA_GetSaveFileName(msaof)
SaveFileNameDlg = Trim(msaof.strFullPathReturned)
Exit Function

PROC_ERR:
MsgBox "The following error occurred: " & Error$
Resume Next
End Function

Private Function CreateFilterString(strPstrFilter As String) As String
On Error GoTo PROC_ERR
Dim strFilter As String
strFilter = strPstrFilter
Do Until right(strFilter, 2) = "||"
strFilter = strFilter & "|"
Loop
Do While InStr(strFilter, "|&quot
Mid(strFilter, InStr(strFilter, "|&quot, 1) = vbNullChar
Loop
CreateFilterString = strFilter
Exit Function

PROC_ERR:
MsgBox "The following error occurred: " & Error$
Resume Next
End Function

Private Function MSA_GetOpenFileName(msaof As gtypMSA_OPENFILENAME) As Integer
On Error GoTo PROC_ERR
' Opens the Open dialog.

Dim of As gtypOPENFILENAME
Dim intRet As Integer

MSAOF_tF msaof, of
intRet = GetOpenFileName(of)
If intRet Then
OF_to_MSAOF of, msaof
End If
MSA_GetOpenFileName = intRet
Exit Function

PROC_ERR:
MsgBox "The following error occurred: " & Error$
Resume Next
End Function

Private Function MSA_GetSaveFileName(msaof As gtypMSA_OPENFILENAME) As Integer
On Error GoTo PROC_ERR
' Opens the file save dialog.

Dim of As gtypOPENFILENAME
Dim intRet As Integer

MSAOF_tF msaof, of
of.Flags = of.Flags Or mOFN_HIDEREADONLY
intRet = GetSaveFileName(of)
If intRet Then
OF_to_MSAOF of, msaof
End If
MSA_GetSaveFileName = intRet
Exit Function

PROC_ERR:
MsgBox "The following error occurred: " & Error$
Resume Next
End Function

Private Sub MSAOF_tF(msaof As gtypMSA_OPENFILENAME, of As gtypOPENFILENAME)
On Error GoTo PROC_ERR
' 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 = "All Files" & vbNullChar & "*.*" & vbNullChar & vbNullChar ' 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)
Exit Sub

PROC_ERR:
MsgBox "The following error occurred: " & Error$
Resume Next
End Sub

Private Sub OF_to_MSAOF(of As gtypOPENFILENAME, msaof As gtypMSA_OPENFILENAME)
On Error GoTo PROC_ERR
' 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
Exit Sub

PROC_ERR:
MsgBox "The following error occurred: " & Error$
Resume Next
End Sub

Regards,
Graham