Re: Common Dialog Box
- From: "(PeteCresswell)" <x@xxxxxxxxx>
- Date: Wed, 06 Jan 2010 10:20:38 -0500
Per Daedalus:
Hi
I can't find the proper way to use a common dialog box (file selection) on
one of my forms, though I'm sure it can not be too difficult. So I guess you
guys can help me out ?
Greater minds than mine will probably chime in with simpler
solutions - like an invisible control that can be placed on the
form and addressed via VBA code.
Having said that, here's what I've been using for some years now.
Two modules:
- First is the common file dialog
- Second supports the error trapping calls in the first
Common File
-----------------------------------------------------------
Option Compare Database 'Use database order for string
comparisons
Option Explicit
Const mModuleName = "basCommonFileDialog"
Public Declare Function GetOpenFileName Lib "comdlg32.dll" Alias
"GetOpenFileNameA" (mCFI As CommonFileInfo) As Integer
Public Declare Function GetSaveFileName Lib "comdlg32.dll" Alias
"GetSaveFileNameA" (mCFI As CommonFileInfo) As Integer
Public Declare Function CommDlgExtendedError Lib "comdlg32.dll"
Alias "CommDlgExtendedErrorA" () As Integer
Const gMainAccessWindowClassName = "OMain" '
Windows Class name for the main Access Window.
'---------------------------------------------
' Data structure used by the Common File dialog
Type CommonFileInfo
lStructSize As Long
hWndOwner As Long
hInstance As Long
lpstrFilter As String
lpstrCustomFilter As String
' lpstrCustomFilter As long
nMaxCustFilter 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
lCustData As Long
lpfnHook As Long
lpTemplateName As Long
End Type
Dim mCFI As CommonFileInfo
Global Const gOFN_READONLY = &H1
Global Const gOFN_FILEMUSTEXIST = &H1000
Global Const gOFN_OVERWRITEPROMPT = &H2
Global Const gOFN_HIDEREADONLY = &H4
Global Const gOFN_SHOWHELP = &H10 'Shows/hides "Help"
button on dialog
Global Const gOFN_CREATEPROMPT = &H2000
Global Const gOFN_EXPLORER = &H80000
'----------------------------------------------
' You also might want to use one or more of these...
'Global Const gOFN_NOCHANGEDIR = &H8
'Global Const gOFN_SHOWHELP = &H10
'Global Const gOFN_ENABLEHOOK = &H20
'Global Const gOFN_ENABLETEMPLATE = &H40
'Global Const gOFN_ENABLETEMPLATEHANDLE = &H80
'Global Const gOFN_NOVALIDATE = &H100
Global Const gOFN_ALLOWMULTISELECT = &H200
'Global Const gOFN_EXTENSIONDIFFERENT = &H400
'Global Const gOFN_PATHMUSTEXIST = &H800
'Global Const gOFN_CREATEPROMPT = &H2000
'Global Const gOFN_SHAREAWARE = &H4000
'Global Const gOFN_NOREADONLYRETURN = &H8000
'Global Const gOFN_NOTESTFILECREATE = &H10000
'Global Const gOFN_SHAREFALLTHROUGH = 2
'Global Const gOFN_SHARENOWARN = 1
'Global Const gOFN_SHAREWARN = 0
' ---------------------------------------------
' API Calls/Data structure/constants used by Browse Folders
dialog
'
Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA"
(ByVal lpString1 As String, ByVal lpString2 As String) As Long
Private Declare Function SendMessage Lib "user32" Alias
"SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal
wParam As Long, ByVal lParam As String) As Long
Private Declare Function SHBrowseForFolder Lib "shell32" (lpbi As
BrowseInfo) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32" (ByVal
pidList As Long, ByVal lpBuffer As String) As Long
Private Const mBIF_RETURNONLYFSDIRS = 1
Private Const mBIF_DONTGOBELOWDOMAIN = 2
Private Const mMAX_PATH = 260
Private Const mBIF_USENEWUI = &H40
Private Const mBIF_NOCREATEDIRS = &H200
Private Const mWM_USER = &H400
Private Const mBFFM_INITIALIZED = 1
Private Const mBFFM_SELCHANGED = 2
Private Const mBFFM_SETSTATUSTEXT = (mWM_USER + 100)
Private Const mBFFM_SETSELECTION = (mWM_USER + 102)
Private Type BrowseInfo
hWndOwner As Long
pIDLRoot As Long
pszDisplayName As Long
lpszTitle As Long
ulFlags As Long
lpfnCallback As Long
lParam As Long
iImage As Long
End Type
Dim mStartingDirectory As String
'---------------------------------------------
Function CommonFileDialog_Open(ByVal theDialogTitle As String,
ByVal theStartingDir As String, ByVal theSuffix As String, ByVal
theSuffixDescription As String) As String
1000 debugStackPush "CommonFileDialog_Open"
1001 On Error GoTo CommonFileDialog_Open_err
' PURPOSE: To issue a common file dialog and return whatever
the path the user chose
' ACCEPTS: - Title string for the dialog
' - Starting directory
' RETURNS: Chosen UNC or zero-length string if user didn't
choose anything
1002 Dim myDialogTitle As String
Dim myFileFilter As String
Dim myChosenFile As String
Dim myChosenPath As String
Dim myStartingDir As String
Dim myDefaultExtension As String
Dim myApiResult As Boolean
'---------------------------------------------------
' Define the filter string and allocate space in the "c"
string
'
1010 If Len(theSuffix) > 0 Then
1011 myFileFilter = theSuffixDescription & " (*." & theSuffix
& ")" & Chr$(0) & "*." & theSuffix & Chr$(0)
1019 End If
1021 myFileFilter = myFileFilter & "All Files (*.*) " & Chr$(0) &
"*.*" & Chr$(0)
1029 myFileFilter = myFileFilter & Chr$(0)
'---------------------------------------------------
' Allocate string space for the strings to be returned
'
1030 myChosenPath = Chr$(0) & Space$(255) & Chr$(0)
1039 myChosenFile = Space$(255) & Chr$(0)
1040 myDialogTitle = theDialogTitle & Chr$(0) 'Give
the dialog a caption title.
1049 myDefaultExtension = theSuffix & Chr$(0)
'1040 If theStartingDir & "" = "" Then
'1042 myStartingDir = CurDir$ 'This
is where the dialog points when opened
'1044 Else
1056 myStartingDir = theStartingDir
'1048 End If
1059 myStartingDir = myStartingDir & Chr$(0)
'-----------------------------------------------
' Load various other fields in the API's data structure
'
1100 With mCFI
1102 .hWndOwner = Application.hWndAccessApp
1103 .hInstance = 0
1104 .lpstrFilter = myFileFilter 'lstrcpy(myFileFilter,
myFileFilter)
1105 .nFilterIndex = 1
1106 .lpstrFile = myChosenPath 'lstrcpy(myChosenPath,
myChosenPath)
1107 .nMaxFile = Len(myChosenPath)
1108 .lpstrFileTitle = myChosenFile 'lstrcpy(myChosenFile,
myChosenFile)
1109 .nMaxFileTitle = Len(myChosenFile)
1110 .lpstrTitle = myDialogTitle 'lstrcpy(myDialogTitle,
myDialogTitle)
'1120 .flags = gOFN_READONLY
1121 .lpstrDefExt = myDefaultExtension
'lstrcpy(myDefaultExtension, myDefaultExtension)
1123 .lpstrCustomFilter = 0
1124 .nMaxCustFilter = 0
1125 .lpstrInitialDir = myStartingDir 'lstrcpy(myStartingDir,
myStartingDir)
1126 .nFileOffset = 0
1127 .nFileExtension = 0
1128 .lCustData = 0
1129 .lpfnHook = 0
1130 .lpTemplateName = 0
1131 .lStructSize = Len(mCFI) 'Allocate space for
the API's data structure
1199 End With
'----------------------------------------------
' Pass the data structure to the Windows API, which
' will display the Open Dialog form.
' myChosenPath will have an embedded Chr$(0) at the end
' We strip this character from the string.
1910 myApiResult = GetOpenFileName(mCFI)
1911 If myApiResult = True Then
1912 myChosenPath = mCFI.lpstrFile
1920 myChosenPath = Left$(myChosenPath, InStr(myChosenPath,
Chr$(0)) - 1)
1930 CommonFileDialog_Open = myChosenPath
1940 Else
1950 CommonFileDialog_Open = ""
1999 End If
CommonFileDialog_Open_xit:
debugStackPop
On Error Resume Next
Exit Function
CommonFileDialog_Open_err:
bugAlert True, ""
Resume CommonFileDialog_Open_xit
End Function
Public Function CommonFileDialog_Save(ByVal theDialogTitle As
String, theStartingDir, ByVal theSuggestedName As String, ByVal
theSuffix As String, ByVal theSuffixDescription As String) As
String
debugStackPush "CommonFileDialog_Save"
On Error GoTo CommonFileDialog_Save_err
' PURPOSE: To present Windows' Common File Dialog in "Save" mode.
' ACCEPTS: - A title for the window
' - A path to the directory where the window should
initially be pointing to
' - A default name for the file
'
' NOTES: 1) If the user types something shorter than the
suggested name, .lpstrFile
' contains the entire suggested name overlayed with
the shorter name.
' The shorter name, however, is terminated with a hex
zero, so we just
' have to scan for that terminator to extract the
correct file path.
Dim myDialogTitle As String
Dim myFileFilters As String
Dim mySpecifiedFile As String
Dim mySpecifiedPath As String
Dim myStartingDir As String
Dim myDefaultExtension As String
Dim myApiResult As Boolean
Dim L As Long
Dim myPath As String
'---------------------------------------------------
' Define the filter string and allocate space in the "c" string
'
myFileFilters = theSuffixDescription & "(*." & theSuffix & ")" &
Chr$(0) & "*." & theSuffix & Chr$(0)
myFileFilters = myFileFilters & "All Files" & Chr$(0) & "*.*" &
Chr$(0)
myFileFilters = myFileFilters & Chr$(0)
'---------------------------------------------------
' Allocate string space for the returned strings.
'
If theSuggestedName & "" <> "" Then
mySpecifiedPath = theSuggestedName & Chr$(0) & Space$(255 -
Len(theSuggestedName)) & Chr$(0)
Else
mySpecifiedPath = Chr$(0) & Space$(255) & Chr$(0)
End If
mySpecifiedFile = Space$(255) & Chr$(0)
myDialogTitle = theDialogTitle & Chr$(0) 'Give the
dialog a caption title.
myDefaultExtension = "TXT" & Chr$(0) 'If user
does not specify an extension, append TXT.
If theStartingDir & "" = "" Then
myStartingDir = CurDir$ 'This is
where the dialog points when opened
Else
myStartingDir = theStartingDir
End If
myStartingDir = myStartingDir & Chr$(0)
'-----------------------------------------------
' Load various other fields in the API's data structure
'
With mCFI
.hWndOwner = Application.hWndAccessApp
.hInstance = 0
.lpstrFilter = myFileFilters 'lstrcpy(myFileFilters,
myFileFilters)
.nFilterIndex = 1
.lpstrFile = mySpecifiedPath
.nMaxFile = Len(mySpecifiedPath)
.lpstrFileTitle = mySpecifiedFile
.nMaxFileTitle = Len(mySpecifiedFile)
.lpstrTitle = myDialogTitle
.Flags = gOFN_OVERWRITEPROMPT Or gOFN_HIDEREADONLY
.lpstrDefExt = myDefaultExtension
.lpstrCustomFilter = 0
.nMaxCustFilter = 0
.lpstrInitialDir = myStartingDir
.nFileOffset = 0
.nFileExtension = 0
.lCustData = 0
.lpfnHook = 0
.lpTemplateName = 0
.lStructSize = Len(mCFI) 'Allocate space for the API's
data structure
End With
'----------------------------------------------
' Pass the data structure to the Windows API, which
' will display the Open Dialog form.
' mySpecifiedPath will have an embedded Chr$(0) at the
' end. You may wish to strip this character from the string.
myApiResult = GetSaveFileName(mCFI)
If myApiResult = True Then
' mySpecifiedPath = Left$(mySpecifiedPath,
InStr(mySpecifiedPath, Chr$(0)) - 1)
L = InStr(1, mCFI.lpstrFile, Chr$(0))
If L > 0 Then 'Take everything up to the first hex
zero
myPath = Left$(mCFI.lpstrFile, L - 1)
Else
myPath = ""
End If
Else
myPath = ""
End If
CommonFileDialog_Save = myPath
CommonFileDialog_Save_xit:
debugStackPop
On Error Resume Next
Exit Function
CommonFileDialog_Save_err:
bugAlert True, ""
Resume CommonFileDialog_Save_xit
End Function
Public Function BrowseForFolder(ByVal theDialogTitle As String,
theStartingDirectory As String) As String
2000 debugStackPush "BrowseForFolder"
2001 On Error GoTo BrowseForFolder_err
' PURPOSE: To issue a Browse Folders dialog and return
whatever the directory the user chose
' ACCEPTS: - Title string for the dialog
' RETURNS: Chosen directory path or zero-length string if user
didn't choose anything
2002 Dim myBI As BrowseInfo
Dim myTitle As String
Dim myBuffer As String
Dim myResult As Long
Dim myIdListPtr As Long
2010 myTitle = theDialogTitle
2019 mStartingDirectory = theStartingDirectory
2020 With myBI
2021 .hWndOwner = Application.hWndAccessApp ' Owner Form
2022 .lpszTitle = lstrcat(myTitle, "")
2023 .lpfnCallback = GetAddressOfFunction(AddressOf
browseCallback)
2024 .ulFlags = mBIF_RETURNONLYFSDIRS + mBIF_DONTGOBELOWDOMAIN
+ mBIF_USENEWUI + mBIF_NOCREATEDIRS
2029 End With
2030 myResult = SHBrowseForFolder(myBI)
2040 If (myResult) Then
2041 myBuffer = Space(mMAX_PATH)
2042 SHGetPathFromIDList myResult, myBuffer
2043 myBuffer = Left(myBuffer, InStr(myBuffer, vbNullChar) - 1)
2044 BrowseForFolder = myBuffer
2049 End If
BrowseForFolder_xit:
debugStackPop
On Error Resume Next
Exit Function
BrowseForFolder_err:
bugAlert True, ""
Resume BrowseForFolder_xit
End Function
Private Function GetAddressOfFunction(theFunctionPointer As Long)
As Long
debugStackPush mModuleName & ": GetAddressofFunction"
On Error GoTo GetAddressofFunction_err
' PURPOSE: To assign a function pointer to a variable
' ACCEPTS: Function pointer
' RETURNS: Variable
GetAddressOfFunction = theFunctionPointer
GetAddressofFunction_xit:
debugStackPop
On Error Resume Next
Exit Function
GetAddressofFunction_err:
bugAlert True, ""
Resume GetAddressofFunction_xit
End Function
Private Function browseCallback(ByVal theWindowPointer As Long,
ByVal theDialogMessage As Long, ByVal lp As Long, ByVal pData As
Long) As Long
' NO ERROR TRAPPING - to prevent an error from propagating back
into the calling process - suggested by MS' Q179378
On Error Resume Next
' PURPOSE: To provide a vehicle for initializing the path in
SHBrowseForFolder.
' ACCEPTS: - Pointer to window that owns the dialog
' - 'Message' from dialog telling us what it's current
state is
' - (apparently-unused 'lp')
' - (apparently-unused 'pData')
' USES: Module-level variable that contains path of directory
we want to initialize dialog to
' RETURNS: Zero, no matter what
Dim L As Long
Dim myBuffer As String
Select Case theDialogMessage
Case mBFFM_INITIALIZED
Call SendMessage(theWindowPointer, mBFFM_SETSELECTION, 1,
mStartingDirectory)
Case mBFFM_SELCHANGED
myBuffer = Space(mMAX_PATH)
L = SHGetPathFromIDList(lp, myBuffer)
If L = 1 Then
Call SendMessage(theWindowPointer, mBFFM_SETSTATUSTEXT,
0, myBuffer)
End If
End Select
browseCallback = 0
End Function
-----------------------------------------------------------
Error Trapping
-----------------------------------------------------------
Option Compare Database 'Use database order for string
comparisons
Option Explicit
' This module contains the routines used to trap/log errors and
' show the "bugAlert" screen. It is derived from my "real"
bugAlert module,
' but stripped down to the bare essentials to the end of
placating any code that
' calls the bugAlert routines (namely debugStackPush(),
debugStackPop, and bugAlert().
' Every procedure should have the following boilerplate in it to
implement
' error trapping. What I do is create a .txt file with that
boilerplate
' in it, with the single quotes removed. Then I just copy/paste
from the
' .txt file each time I starting writing a routine. After
pasting in the
' boilerplate, I just do a rename of "xxx" to the procedure name.
' Pete Cresswell
' 3/3/2003
' -----------------------------------------
' debugStackPush Me.Name & ": xxx"
' On Error GoTo xxx_err
'' PURPOSE: To
'xxx_xit:
' debugStackPop
' On Error Resume Next
' Exit Sub
'
'xxx_err:
' bugAlert True, ""
' Resume xxx_xit
' -----------------------------------------
Const mModuleName = "basBugAlert_Lite"
Const mDebugStackTotalSize = 52
Global gDebugStack(mDebugStackTotalSize)
Global Const gStackLimit = 50
Global gStackPointer As Integer
Sub bugAlert(ByVal theDisplaySwitch As Integer, ByVal
theSupplementalMessage As String)
' PURPOSE: To show information about the trapped error
' ACCEPTS: - A switch that the "real" version of bugAlert uses to
decide how large and detailed
' a screen to show
' - Optional message text that the calling routine might
want to supply for
' display with the error message
'
' NOTES: 1) The "real" version logs the error in a text file.
Dim myErrorLine As Long
Dim myErrorNumber As Long
Dim myErrorMessage As String
Dim myErrorLocation As String
myErrorLine = Erl 'Capture relevant info ASAP.
Dunno why, but intuitively it seems like a good idea.
myErrorNumber = Err
myErrorMessage = Error$
myErrorLocation = gDebugStack(gStackPointer)
MsgBox myErrorLocation & ", Line " & Format$(myErrorLine,
"000000") & " " & Format$(myErrorNumber, "0000") & ": " &
myErrorMessage & vbCrLf & theSupplementalMessage, vbCritical,
"There's Trouble In River City!"
End Sub
Sub debugStackPop()
On Error GoTo debugStackPop_err
' PURPOSE: To pop the last procedure name off the top of the
debug stack
Dim i As Integer
If gStackPointer <= gStackLimit Then
gDebugStack(gStackPointer) = ""
End If
gStackPointer = gStackPointer - 1
If gStackPointer < 0 Then
gStackPointer = 0
End If
debugStackPop_xit:
On Error Resume Next
Exit Sub
debugStackPop_err:
MsgBox "debugStackPop() failed. Error " & Str(Err) & ": " &
Error$, 48, "Error In Error Handler"
Resume debugStackPop_xit
End Sub
Sub debugStackPush(ByVal theProcedureName As String)
On Error GoTo debugStackPush_err
' PURPOSE: To push a procedure name into the debug stack
' ACCEPTS: The procedure name
Dim i As Integer
gStackPointer = gStackPointer + 1
If gStackPointer <= gStackLimit Then
gDebugStack(gStackPointer) = theProcedureName
Else
gDebugStack(gStackLimit + 2) = theProcedureName
End If
debugStackPush_xit:
On Error Resume Next
Exit Sub
debugStackPush_err:
MsgBox "debugStackPush() failed. Error " & Str(Err) & ": " &
Error$, 48, "Error In Error Handler"
Resume debugStackPush_err
End Sub
Sub zzTestBugAlert()
debugStackPush mModuleName & ": zzTestBugAlert"
On Error GoTo zzTestBugAlert_err
' PURPOSE: To supply a model for using the BugAlert routines and
to demo the routines
'
' NOTES: 1) Fire up a Debug window and type "zzTestBugAlert"
DoCmd.OpenForm "frmNon-Existant"
zzTestBugAlert_xit:
debugStackPop
On Error Resume Next
Exit Sub
zzTestBugAlert_err:
bugAlert False, "This is the supplemental text...."
Resume zzTestBugAlert_xit
End Sub
-----------------------------------------------------------
--
PeteCresswell
.
- References:
- Common Dialog Box
- From: Daedalus
- Common Dialog Box
- Prev by Date: Re: Common Dialog Box
- Next by Date: Office 2010 pricing
- Previous by thread: Re: Common Dialog Box
- Next by thread: Office 2010 pricing
- Index(es):
Relevant Pages
|
