Use the comdlg32.dll dialog objects - here are examples from VBA Developer's Handbook together with a few custom functions of my own - copy the following into a module and off you go All the best, Do
Option Compare Databas
Option Explici
' From "VBA Developer's Handbook
' by Ken Getz and Mike Gilber
' Copyright 1997; Sybex, Inc. All rights reserved
' Examples from Chapter 1
Private Type OPENFILENAM
lngStructSize As Long ' Size of structur
hWndOwner As Long ' Owner window handl
hInstance As Long ' Template instance handl
strfilter As String ' Filter strin
strCustomFilter As String ' Selected filter strin
intMaxCustFilter As Long ' Len(strCustomFilter
intFilterIndex As Long ' Index of filter strin
strfile As String ' Selected filename & pat
intMaxFile As Long ' Len(strFile
strFileTitle As String ' Selected filenam
intMaxFileTitle As Long ' Len(strFileTitle
strInitialDir As String ' Directory nam
strTitle As String ' Dialog titl
lngFlags As Long ' Dialog flag
intFileOffset As Integer ' Offset of filenam
intFileExtension As Integer ' Offset of file extensio
strDefExt As String ' Default file extensio
lngCustData As Long ' Custom data for hoo
lngfnHook As Long ' LP to hook functio
strTemplateName As String ' Dialog template nam
End Typ
Declare Function GetOpenFileName Lib "comdlg32.dll"
Alias "GetOpenFileNameA" (ofn As OPENFILENAME) As Boolea
Declare Function GetSaveFileName Lib "comdlg32.dll"
Alias "GetSaveFileNameA" (ofn As OPENFILENAME) As Boolea
' Open/Save dialog flag
Global Const OFN_READONLY = &H
Global Const OFN_OVERWRITEPROMPT = &H
Global Const OFN_HIDEREADONLY = &H
Global Const OFN_NOCHANGEDIR = &H
Global Const OFN_SHOWHELP = &H1
Global Const OFN_NOVALIDATE = &H10
Global Const OFN_ALLOWMULTISELECT = &H20
Global Const OFN_EXTENSIONDIFFERENT = &H40
Global Const OFN_PATHMUSTEXIST = &H80
Global Const OFN_FILEMUSTEXIST = &H100
Global Const OFN_CREATEPROMPT = &H200
Global Const OFN_SHAREAWARE = &H400
Global Const OFN_NOREADONLYRETURN = &H800
Global Const OFN_NOTESTFILECREATE = &H1000
Global Const OFN_NONETWORKBUTTON = &H2000
Global Const OFN_NOLONGNAMES = &H4000
' Flags for hook functions and dialog template
'Global Const OFN_ENABLEHOOK = &H2
'Global Const OFN_ENABLETEMPLATE = &H4
'Global Const OFN_ENABLETEMPLATEHANDLE = &H8
' Windows 95 flag
Global Const OFN_EXPLORER = &H8000
Global Const OFN_NODEREFERENCELINKS = &H10000
Global Const OFN_LONGNAMES = &H20000
' Custom flag combination
Global Const dhOFN_OPENEXISTING = OFN_PATHMUSTEXIST Or OFN_FILEMUSTEXIST Or OFN_HIDEREADONL
Global Const dhOFN_SAVENEW = OFN_PATHMUSTEXIST Or OFN_OVERWRITEPROMPT Or OFN_HIDEREADONL
Global Const dhOFN_SAVENEWPATH = OFN_OVERWRITEPROMPT Or OFN_HIDEREADONL
Private Declare Function GetActiveWindow Lib "user32" () As Lon
Function dhFileDialog(
Optional strInitDir As String,
Optional strfilter As String =
"All files (*.*)" & vbNullChar & "*.*" &
vbNullChar & vbNullChar,
Optional intFilterIndex As Integer = 1,
Optional strDefaultExt As String = "",
Optional strFileName As String = "",
Optional strDialogTitle As String = "Open File",
Optional hwnd As Long = -1,
Optional fOpenFile As Boolean = True,
Optional ByRef lngFlags As Long =
dhOFN_OPENEXISTING) As Varian
' Wrapper function for the GetOpenFileName API function
' Displays the common open/save as dialog and return
' the file(s) selected by the user
' From "VBA Developer's Handbook
' by Ken Getz and Mike Gilber
' Copyright 1997; Sybex, Inc. All rights reserved
' In
' strInitDir (Optional
' Inital directory
' strFilter (Optional
' File filter as null delimited/double-nul
' terminated string
' intFilterIndex (Optional, default = 1
' Initial filter index.
' strDefaultExt (Optional)
' Default file extension if none specified.
' strFilename (Optional)
' Initial file name for dialog.
' strDialogTitle (Optional, default = "Open File")
' Dialog title.
' hwnd (Optional, default = -1)
' Handle of dialog owner window.
' fOpenFile (Optional, default = True)
' If True, displays Open dialog, if False,
' displays Save As dialog.
' lngFlags (Optional)
' Flags for API function (see declarations section).
' Out:
' lngFlags
' Returns flags set by the API function after closing
' the dialog.
' Return Value:
' Name of the file or files chosen by the user.
' Note:
' If you allow multi-select, returned string will
' be the directory name followed by a space-delimited
' list of files.
' Example:
' strFile = dhFileDialog(strFilter:="All files" & _
' vbNullChar & "*.*" & vbNullChar & vbNullChar)
Dim ofn As OPENFILENAME
Dim strFileTitle As String
Dim fResult As Boolean
' Fill in some of the missing arrguments
If strInitDir = "" Then
strInitDir = CurDir
End If
If hwnd = -1 Then
hwnd = GetActiveWindow()
End If
' Set up the return buffers
strFileName = strFileName & String(1000 - Len(strFileName), 0)
strFileTitle = String(1000, 0)
' Fill in the OPENFILENAME structure members
With ofn
.lngStructSize = Len(ofn)
.hWndOwner = hwnd
.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
' Call the right function
If fOpenFile Then
fResult = GetOpenFileName(ofn)
Else
fResult = GetSaveFileName(ofn)
End If
' If successful, return the filename,
' otherwise return Null
If fResult Then
' Return any flags to the calling procedure
lngFlags = ofn.lngFlags
' Return the result
If (ofn.lngFlags And OFN_ALLOWMULTISELECT) = 0 Then
dhFileDialog = dhTrimNull(ofn.strfile)
Else
dhFileDialog = ofn.strfile
End If
Else
dhFileDialog = Null
End If
End Function
Sub dhTestDialog()
' Test function for dhFileDialog function.
' From "VBA Developer's Handbook"
' by Ken Getz and Mike Gilbert
' Copyright 1997; Sybex, Inc. All rights reserved.
' In:
' n/a
' Out:
' n/a
' Example:
' Call dhTestDialog()
' Open a file in the current directory
Debug.Print dhFileDialog()
' Open multiple files in the Windows directory
Debug.Print dhFileDialog(strInitDir:="C:\WINDOWS", _
lngFlags:=dhOFN_OPENEXISTING Or OFN_ALLOWMULTISELECT _
Or OFN_EXPLORER)
' Save a file as a text file
Debug.Print dhFileDialog(strfilter:="Text Files" & _
vbNullChar & "*.txt" & vbNullChar & vbNullChar, _
strDialogTitle:="Save As", lngFlags:=dhOFN_SAVENEW, _
fOpenFile:=False)
End Sub
Function GetTextFileName(ByVal strTitle As String) As String
'calls common dialog for test file with title strtitle
Dim strInitDir As String
On Error GoTo ProcError
strInitDir = GetDrive("Zur GGL\09 Testing\01 UnitTest\Testing Input Output Files & Raw Data") & "\"
GetTextFileName = Nz(dhFileDialog(strInitDir, _
"Text Files *.txt", _
1, _
"txt", , _
strTitle, , , _
OFN_FILEMUSTEXIST + OFN_PATHMUSTEXIST), "")
ProcExit:
Exit Function
ProcError:
MsgBox Error(Err)
Resume ProcExit
End Function
Function SaveTextFile(ByVal strTitle As String, strFileName As String) As String
'calls common dialog for test file with title strtitle
Dim strInitDir As String
On Error GoTo ProcError
strInitDir = GetThisPath("export")
SaveTextFile = Nz(dhFileDialog(strInitDir, _
"Text Files *.txt", _
1, _
"txt", _
strFileName, _
strTitle, , _
False, _
OFN_PATHMUSTEXIST), "")
ProcExit:
Exit Function
ProcError:
MsgBox Error(Err)
Resume ProcExit
End Function
Function GetAccessDBName(ByVal strTitle As String) As String
'calls common dialog for test file with title strtitle
Dim strInitDir As String
Dim strfilter As String
On Error GoTo ProcError
strfilter = "Access files" & vbNullChar & "*.mdb" & vbNullChar & vbNullChar
strInitDir = GetPath(CurrentDb.Name)
GetAccessDBName = Nz(dhFileDialog(strInitDir, _
strfilter, _
0, _
"mdb", , _
strTitle, , , _
OFN_FILEMUSTEXIST + OFN_PATHMUSTEXIST), "")
ProcExit:
Exit Function
ProcError:
MsgBox Error(Err)
Resume ProcExit
End Function
