Per Jeff Garrison:
Do you let them select the file to attach and them move
it to a directory? If so, I would definitely be interested in doing that.
Yes but.... Nothing gets copied until they click "OK" on a confirmation dialog
that pops after they make their choices. The same dialog lets them enter
more personalized descriptions of the documents.
Needless to say, that's going to be quite a bit of code.
I use the FollowHyperLink command to open an attachement.
As long as the Windows knows what to do with docs that have a given suffix
it seems to work 100%. Works for me bc my guys have only .doc, .xls,
and .pdf attachments.
Here's the code I call when somebody doubleclicks an attachment in order
to view it.
=====================================================================
Public Sub DocumentOpenViaWindows(ByVal theAttachmentID As Long)
5000 debugStackPush mModuleName & ": DocumentOpenViaWindows"
5001 On Error GoTo DocumentOpenViaWindows_err
' PURPOSE: To cause MS Windows to open up the document pointed to by the
attachment record in question
' ACCEPTS: ID of attachment record in question
5002 Dim myRS As DAO.Recordset
Dim myQuery As DAO.QueryDef
Dim myFS As Object
Dim myAttachmentDir As String
Dim myDocumentName As String
5010 DoCmd.Hourglass True
5019 myAttachmentDir = IniValue_Get(gProgramParms, gParmName_AttachmentDir)
5020 If Len(myAttachmentDir) = 0 Then
5021 BugAlert True, "Missing '" & gParmName_AttachmentDir & "' parm in '" &
SysCmd(acSysCmdIniFile) & "'."
5029 Else
5030 Set myQuery = CurrentDb.QueryDefs("qryDocumentOpenViaWindows")
5031 With myQuery
5032 .Parameters("theAttachmentID") = theAttachmentID
5033 Set myRS = .OpenRecordset(dbOpenSnapshot, dbForwardOnly)
5039 End With
5040 With myRS
5041 If ((.BOF = True) And (.EOF = True)) Then
5042 BugAlert True, "No attachment rec found for AttachmentID='" &
theAttachmentID & "'."
5043 Else
5044 FollowHyperlink myAttachmentDir & "\" & !DocumentName_App
5045 End If
5049 End With
5998 End If
5999 DoCmd.Hourglass False
DocumentOpenViaWindows_xit:
DebugStackPop
On Error Resume Next
Set myFS = Nothing
myQuery.Close
Set myQuery = Nothing
myRS.Close
Set myRS = Nothing
Exit Sub
DocumentOpenViaWindows_err:
BugAlert True, "AttachmentID='" & theAttachmentID & "', AttachmentDir='" &
myAttachmentDir & "', DocumentName='" & myDocumentName & "'."
Resume DocumentOpenViaWindows_xit
End Sub
=============================================
Adding new attachments is where the code volume comes in.
I'd post an example .MDB, but this stuff is too intertwined with the rest of my
app and it would take me hours to concoct a working example.
For what it's worth, here's the code behind my "Add Attachments" form.
This is the click event in the parent form that starts the process
by opening the "Add Attachments" form.
=============================================
Private Sub cmdNewAttachment_Click()
debugStackPush Me.Name & ": cmdNewAttachment_Click"
On Error GoTo cmdNewAttachment_Click_err
' PURPOSE: To begin the process of adding a new attachment and then,
' if user completed the process, requery this form's attachment list
'
' NOTES: 1) All this happens while frmDeal is in "Change" mode. Therefore
' whatever happens happens only within the cache, and not the
' back end tables. The real deal doesn't go down until user
' clicks the "Save" button and the back end gets updated with
' what's in the cache.
Dim myDealID As Long
Dim myNodeKeyText As String
Const operationCancelled = 2501
myDealID = mCurLoaded_DealID
gModalDialogOutcome = False
DoCmd.OpenForm "frmAttachment_AddNew", , , , , acDialog, myDealID 'Code stops
here until user closes that form.
If gModalDialogOutcome = True Then
With Me
.MakeDirty_Attachment
.subAttachments.Form.Requery
.tabMain.Pages(mDealPageNum_Attachments).Visible = True
.tabMain.Value = mDealPageNum_Attachments
End With
End If
cmdNewAttachment_Click_xit:
DebugStackPop
On Error Resume Next
Exit Sub
cmdNewAttachment_Click_err:
Select Case Err
Case operationCancelled
'Do nothing. Doc choice failed edit check in
frmAttachment_AddNew.FormOpen()
Case Else
BugAlert True, ""
End Select
Resume cmdNewAttachment_Click_xit
End Sub
And here's the code behind the "Add Attachments" form:
=========================================================
Option Compare Database
Option Explicit
'Next available line# series = 4000
Dim mDealID As Long
Dim mUserID As String
Dim mDocumentName_User As String
Dim mDocumentPath_User As String
Const mExternalAttachmentSourceDirParmName = "ExternalAttachmentSourceDir"
Private Sub cmdCancel_Click()
debugStackPush Me.Name & ": cmdCancel_Click"
On Error GoTo cmdCancel_Click_err
' PURPOSE: To allow user to abort the process
DoCmd.Close acForm, Me.Name
cmdCancel_Click_xit:
DebugStackPop
On Error Resume Next
Exit Sub
cmdCancel_Click_err:
BugAlert True, ""
Resume cmdCancel_Click_xit
End Sub
Private Sub cmdOk_Click()
1000 debugStackPush Me.Name & ": cmdOk_Click"
1001 On Error GoTo cmdOk_Click_err
' PURPOSE: - To prompt user to navigate to the attachment,
' - Create pointer to same in ttblDealCache_Attachment,
' - Load the new attachment ID into global semaphore,
' - Return control to calling routine by closing this form (which
was
' opened as a modal dialog)
'
' NOTES: 1) Observe that when this routine is running, frmDeal is in
"Change" mode
' and everything we to is done to the cache tables. The real
deal
' does not happen until user hits "Save".
1002 Dim workRS As DAO.Recordset
Dim cacheRS As DAO.Recordset
Dim myDocumentPath_App As String
Dim myUserDir As String
Dim myDocumentName_App As String
Dim myUserID As String
Dim myTimeStamp As Variant
1010 myDocumentPath_App = IniValue_Get(gProgramParms, gParmName_AttachmentDir)
1011 If Len(myDocumentPath_App) = 0 Then
1012 BugAlert True, "Cannot proceed with adding attachment because
'AttachmentDir' parm is missing from '" & SysCmd(acSysCmdIniFile) & "'."
1019 Else
1020 myUserID = CurrentUserGet()
1029 myTimeStamp = Now()
1031 With CurrentDb
1032 Set workRS = .OpenRecordset("ttblAttachment_AddNew", dbOpenSnapshot,
dbOpenDynaset)
1033 Set cacheRS = .OpenRecordset("ttblDealCache_Attachment",
dbOpenDynaset, dbAppendOnly)
1039 End With
1040 With workRS
1049 IniValue_Put mUserID, mExternalAttachmentSourceDirParmName, !DirPath
1050 Do Until .EOF = True
1051 cacheRS.AddNew
1052 cacheRS!DealID = mDealID
1053 cacheRS!AttachmentTypeID = !AttachmentTypeID
1054 cacheRS!EffectiveDate = !EffectiveDate
1055 cacheRS!DocumentName_App = "Deal" & Format$(mDealID, "000000") &
"." & !Filename
1059 cacheRS!DocumentName_User = !Filename
1060 cacheRS!DocumentDescription = !DocumentDescription
1061 cacheRS!DocumentPath_User = !DirPath & "\" & !Filename
1062 cacheRS!IsNew = True
1063 cacheRS!CreatedAt = myTimeStamp
1064 cacheRS!CreatedBy = myUserID
1065 cacheRS.Update
1066 .MoveNext
1069 Loop
1099 End With
1990 gModalDialogOutcome = True
1991 DoCmd.Close acForm, Me.Name
1999 End If
cmdOk_Click_xit:
DebugStackPop
On Error Resume Next
cacheRS.Close
Set cacheRS = Nothing
workRS.Close
Set workRS = Nothing
Exit Sub
cmdOk_Click_err:
BugAlert True, ""
Resume cmdOk_Click_xit
End Sub
Private Sub Form_Open(Cancel As Integer)
2000 debugStackPush Me.Name & ": Form_Open"
2001 On Error GoTo Form_Open_err
' PURPOSE: - To capture the DealID supplied in .OpenArgs
' - To init EffectiveDate
' - To solicit document paths from the user via a Common File Dialog
' - To parse document paths into a work table
' - To run an edit check on the work table and either continue
opening
' the form or abort.
2002 Dim workRS As DAO.Recordset
Dim cacheRS As DAO.Recordset
Dim myFilesChosen() As String
Dim myResult As String
Dim myStartingDir As String
Dim i As Long
Dim k As Long
Dim myDirPath As String
Dim myFileName As String
Dim myFatalCount As Long
Dim myWarningCount As Long
2009 gModalDialogOutcome = False
2010 Me.subList.Form.RecordSource = ""
2011 mDealID = Val(Me.OpenArgs & "")
2012 If mDealID = 0 Then
2013 BugAlert True, "Expected DealID in .OpenArgs. Found '" & Me.OpenArgs &
"'."
2014 Cancel = True
2019 Else
2020 WorkTable_Create "ttblAttachment_AddNew", "zmtblAttachment_AddNew"
2029 Set workRS = CurrentDb.OpenRecordset("ttblAttachment_AddNew",
dbOpenDynaset, dbAppendOnly)
2030 mUserID = CurrentUserGet()
2040 myStartingDir = IniValue_Get(mUserID,
mExternalAttachmentSourceDirParmName)
2041 myResult = CommonFileDialog_Open("Choose Document", myStartingDir, "",
"", "(any document)", True)
2042 myResult = TrimTrailingNulls(myResult)
2049 k = ParseToArrayOfString(myResult, vbNullChar, myFilesChosen)
2050 Select Case k
Case 0
2060 MsgBox "You did not choose any files", vbExclamation, "No Files
Chosen"
2069 Cancel = True
2070 Case 1 'Common file dialog behaves differently for one
choice vs multiple choices. W/one choice, dir path is concatted to file path
2079 FileNameSeparateFromFullPath myFilesChosen(0), myDirPath,
myFileName
2080 With workRS
2081 .AddNew
2082 !AttachmentTypeID = gAttachmentTypeID_MarketingMaterials
2083 !DirPath = myDirPath
2084 !EffectiveDate = Date
2085 !Filename = myFileName
2086 .Update
2089 End With
2090 errorCheck myWarningCount, myFatalCount
2091 If ShowAnyErrorsToUser(False, myWarningCount, myFatalCount) =
False Then
2092 Cancel = True
2093 Else
2094 Me.subList.Form.RecordSource = "ttblAttachment_AddNew"
2099 End If
2110 Case Is > 1 'As with Case 1 - but now first thing returned is
dir path, then a list of file names
2111 For i = 1 To k - 1
2120 With workRS
2121 .AddNew
2122 !AttachmentTypeID = gAttachmentTypeID_MarketingMaterials
2123 !DirPath = myFilesChosen(0)
2124 !EffectiveDate = Date
2125 !Filename = myFilesChosen(i)
2126 .Update
2127 End With
2129 Next i
2130 errorCheck myWarningCount, myFatalCount
2131 If ShowAnyErrorsToUser(False, myWarningCount, myFatalCount) =
False Then
2132 Cancel = True
2133 Else
2134 Me.subList.Form.RecordSource = "ttblAttachment_AddNew"
2139 End If
2190 Case Else
2191 BugAlert True, "Unexpected value for K='" & k & "'."
2192 End Select
2999 End If
Form_Open_xit:
DebugStackPop
On Error Resume Next
cacheRS.Close
Set cacheRS = Nothing
workRS.Close
Set workRS = Nothing
Exit Sub
Form_Open_err:
BugAlert True, ""
Resume Form_Open_xit
End Sub
Private Sub errorCheck(ByRef theWarningCount As Long, ByRef theFatalCount As
Long)
3000 debugStackPush Me.Name & ": errorCheck"
3001 On Error GoTo errorCheck_err
' PURPOSE: To iterate through the user's document/file choices and identify
any errors
' ACCEPTS: - Pointer to count of warning-level errors
' - Pointer to count of fatal-level errors
3002 Dim workRS As DAO.Recordset
Dim cacheRS As DAO.Recordset
Dim curPath As String
Dim curFileName As String
3010 ErrorCheckWorkDbCreate
3020 With CurrentDb
3021 Set cacheRS = .OpenRecordset("ttblDealCache_Attachment", dbOpenDynaset)
3022 Set workRS = .OpenRecordset("ttblAttachment_AddNew", dbOpenSnapshot,
dbForwardOnly)
3029 End With
3030 With workRS
3031 If ((.BOF = True) And (.EOF = True)) Then
3032 BugAlert True, "No records found in temp table. This should not be
possible."
3039 Else
3040 Do Until .EOF = True
3041 curPath = !DirPath & "\" & !Filename
3042 If FileExist(curPath) = False Then
3043 ErrorCheckWrite gErrorCheckLevel_Fatal, 1, "Document Does Not
Exist: '" & curPath & "'.", theWarningCount, theFatalCount
3049 Else
3050 curFileName = !Filename
3051 cacheRS.FindFirst "DocumentName_User=" & Chr$(34) & curFileName
& Chr$(34)
3052 If cacheRS.NoMatch = False Then
3053 ErrorCheckWrite gErrorCheckLevel_Warning, 2, "Duplicate
Document: '" & !Filename & "'. That document is already attached to this deal.
When you save the deal, it will be replaced by the one you just chose.",
theWarningCount, theFatalCount
3054 End If
3055 End If
3056 .MoveNext
3057 Loop
3058 End If
3059 End With
errorCheck_xit:
DebugStackPop
On Error Resume Next
cacheRS.Close
Set cacheRS = Nothing
workRS.Close
Set workRS = Nothing
Exit Sub
errorCheck_err:
BugAlert True, "curFileName='" & curFileName & "'."
Resume errorCheck_xit
End Sub
===========================================
Finally, here's my implementation of Common File Dialog.
I suspect there are less code-intensive ways to do it - using an invisible
control - but this is how I started way back when and never saw a reason to
abandon something that works...
==============================================
Option Compare Database 'Use database order for string comparisons
Option Explicit
Const mModuleName = "basCommonFileDialog"
Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias
"GetOpenFileNameA" (mOFN As OpenFileName) As Integer
Private Declare Function GetSaveFileName Lib "comdlg32.dll" Alias
"GetSaveFileNameA" (mOFN As OpenFileName) As Integer
Private 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 OpenFileName
lStructSize As Long 'Length, in bytes, of the whole structure
hWndOwner As Long 'Window that owns the dialog box. Null if no
owner
hInstance As Long '
lpstrFilter As String
lpstrCustomFilter As String
' lpstrCustomFilter As Long
nMaxCustFilter As Long
nFilterIndex As Long
lpstrFile As String 'Used to initialize the choice in the dialog
by pre-populating the "File Name:" box
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 mOFN As OpenFileName
Private Const mOFN_READONLY = &H1
Private Const mOFN_FILEMUSTEXIST = &H1000
Private Const mOFN_OVERWRITEPROMPT = &H2
Private Const mOFN_HIDEREADONLY = &H4
Private Const mOFN_SHOWHELP = &H10 'Shows/hides "Help" button on
dialog
Private Const mOFN_CREATEPROMPT = &H2000
Private Const mOFN_AllowMultiSelect = &H200
Private Const mOFN_Explorer = &H80000 'Use the Explorer-like Open A
File dialog box template
' ---------------------------------------------
' 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)
' End stuff used by the Common File dialog
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 thePreChosenFileName As String, ByVal theSuffix
As String, ByVal theSuffixDescription As String, theMultiSelectSwitch As
Boolean) 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
' - File suffix (if any) that the file list sb restricted to
' - English-language explaination of suffix
' - A switch telling whether or not we want the user tb able to
select more than one file
' RETURNS: - Chosen UNC of chosen file if MultiSelect = False, othewise a
series of UNCs delimited by vbNullChar
' (or, in the event user chose nothing, a zero-length string)
'
' NOTES: 1) We get a *lot* of nulls in the string, so in the immediate
window we have to do something to deal
' with them or they will exceed the capacity of the window when
converted to carriage returns.
' One approach: ?Replace(Replace(CommonFileDialog_open("Dialog
Title","C:\Temp","PreChosenFileName.txt","*","All Files",true), vbNullChar &
VbNullChar, ""),vbnullchar,vbcrlf,1)
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 Long
Dim myApiExtendedError As Long
Const myMaxBufferSize As Long = 4096 'Best guess at the biggest chunk
of file names user will grab if/when they use the dialog in multiselect mode
Const myMinBufferSize As Long = 255 'The biggest we think a single
file name would be
'---------------------------------------------------
' Define the filter string and allocate space in the "c" string
'
1010 If Len(theSuffix) > 0 Then
1011 myFileFilter = theSuffixDescription & " (*." & theSuffix & ")" &
vbNullChar & "*." & theSuffix & vbNullChar
1019 End If
1021 myFileFilter = myFileFilter & "All Files (*.*) " & vbNullChar & "*.*" &
vbNullChar
1029 myFileFilter = myFileFilter & vbNullChar
' '---------------------------------------------------
' ' Allocate string space for the strings to be returned
' '
'1031 If theMultiSelectSwitch = True Then
'1032 myChosenFile = Space$(myMinBufferSize) & vbNullChar
'1033 myChosenPath = vbNullChar & Space$(myMinBufferSize) & vbNullChar
'1034 Else
'1035 myChosenFile = Space$(myMaxBufferSize) & vbNullChar
'1036 myChosenPath = vbNullChar & Space$(myMaxBufferSize) & vbNullChar
'1039 End If
1050 myDialogTitle = theDialogTitle & vbNullChar 'Give the dialog a
caption title.
1059 myDefaultExtension = theSuffix & vbNullChar
'1040 If theStartingDir & "" = "" Then
'1042 myStartingDir = CurDir$ 'This is where the
dialog points when opened
'1044 Else
1060 myStartingDir = theStartingDir
'1048 End If
1070 myStartingDir = myStartingDir & vbNullChar
'-----------------------------------------------
' Load various other fields in the API's data structure
'
1100 With mOFN
1120 If theMultiSelectSwitch = True Then
1121 .Flags = mOFN_AllowMultiSelect Or mOFN_Explorer
1129 End If
1102 .hWndOwner = Application.hWndAccessApp
.lpstrCustomFilter = String$(40, vbNullChar)
1130 .lpstrDefExt = myDefaultExtension
1106 .lpstrFile = thePreChosenFileName & String$(myMaxBufferSize -
Len(thePreChosenFileName), vbNullChar)
1108 .lpstrFileTitle = String$(myMaxBufferSize, vbNullChar)
1104 .lpstrFilter = myFileFilter
1110 .lpstrTitle = myDialogTitle
1133 .lpstrInitialDir = myStartingDir
1149 .lStructSize = Len(mOFN)
1105 .nFilterIndex = 1 '<=====??????????
1132 .nMaxCustFilter = Len(.lpstrCustomFilter)
1107 .nMaxFile = Len(.lpstrFile)
1109 .nMaxFileTitle = Len(.lpstrFileTitle)
'1103 .hInstance = 0
'1134 .nFileOffset = 0
'1139 .nFileExtension = 0
'1140 .lCustData = 0
'1141 .lpfnHook = 0
'1142 .lpTemplateName = 0
1199 End With
'----------------------------------------------
' Pass the data structure to the Windows API, which
' will display the Open Dialog form.
' myChosenPath will have an embedded vbNullChar
' (i.e. Chr$(0)) at the end.
' We strip this character from the string.
1310 myApiResult = GetOpenFileName(mOFN)
1311 If myApiResult = 0 Then
'1312 myApiExtendedError = CommDlgExtendedError()
' (Do nothing for now: just assume user just cancelled the dialog. In the
end, though we need to add API error handling'
1319 Select Case myApiResult
Case Else
1399 End Select
1910 Else
1911 myChosenPath = mOFN.lpstrFile
1912 If theMultiSelectSwitch = False Then
1913 myChosenPath = Left$(myChosenPath, InStr(myChosenPath, vbNullChar) -
1)
1914 End If
1915 CommonFileDialog_Open = myChosenPath
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 mOFN
.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 = mOFN_OVERWRITEPROMPT Or mOFN_HIDEREADONLY
.lpstrDefExt = myDefaultExtension
.lpstrCustomFilter = 0
.nMaxCustFilter = 0
.lpstrInitialDir = myStartingDir
.nFileOffset = 0
.nFileExtension = 0
.lCustData = 0
.lpfnHook = 0
.lpTemplateName = 0
.lStructSize = Len(mOFN) '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(mOFN)
If myApiResult = True Then
' mySpecifiedPath = Left$(mySpecifiedPath, InStr(mySpecifiedPath, Chr$(0)) -
1)
L = InStr(1, mOFN.lpstrFile, Chr$(0))
If L > 0 Then 'Take everything up to the first hex zero
myPath = Left$(mOFN.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
Public Function GetOpenFileName2(Owner As Long, File As String, Filter As
String, Title As String, FilterIndex As Long) As String
'Copied from NG post by Bendan Reynolds Access MVP
(e-mail address removed)
Const strcProcedure = "GetOpenFileName"
Dim ofn As OpenFileName
Dim lngExtendedError As Long
With ofn
.Flags = mOFN_AllowMultiSelect Or mOFN_Explorer
.hWndOwner = Owner
.lpstrCustomFilter = String$(40, vbNullChar)
.lpstrDefExt = "MDB"
.lpstrFile = File & String$(2048 - Len(File), vbNullChar)
.lpstrFileTitle = String$(2048, vbNullChar)
.lpstrFilter = Filter
.lpstrInitialDir = CurrentProject.Path
.lpstrTitle = Title
.lStructSize = Len(ofn)
.nFilterIndex = FilterIndex
.nMaxCustFilter = Len(.lpstrCustomFilter)
.nMaxFile = Len(.lpstrFile)
.nMaxFileTitle = Len(.lpstrFileTitle)
End With
If GetOpenFileName(ofn) = 0 Then
lngExtendedError = CommDlgExtendedError()
Select Case lngExtendedError
'error handling omitted for brevity ...
End Select
Else
GetOpenFileName2 = Replace(ofn.lpstrFile, vbNullChar, "*")
End If
End Function
==============================================
