The code I found on the web does not allow the creation of a folder. I've been searching for a "better" select code sample.
I found this code at http://www.mrexcel.com/forum/excel-q...lications.html
posted by Richard Schollar in 2007 (post #2). Seems to be MUCH better than what I am currently using. Time to change....
I did make a small change in the code:
Code:
Function GetFolder(strPath As String) As String
Dim fldr As FileDialog
Dim sItem As String
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
.Title = "Select a Folder"
.ButtonName = "Select Folder"
.AllowMultiSelect = False
.InitialFileName = strPath
If .Show <> -1 Then GoTo NextCode
sItem = .SelectedItems(1)
End With
NextCode:
GetFolder = sItem
Set fldr = Nothing
End Function
The line in blue is what I added.
This is how you call it:
Code:
Private Sub cmdSelectFolder_Click() '<<= example button
Dim FolderPath As String
Dim sDefaultPath as string
sDefaultPath = CurrentProject.path
FolderPath = GetFolder(sDefaultPath)
MsgBox FolderPath
End Sub
You must set a reference to "Microsoft Office xx.0 Object Library" where xx is your version. Access 2010 version is 14.
Here is a cut down version:
Code:
Private Sub cmdExportData_Click()
On Error GoTo Err_cmdExportData_Click
Dim strSaveFileName As String
Dim sPath As String
Dim bStatusBar As Variant
'msgbox variables
Dim Msg, Style, Title, Response
'save current status bar state
bStatusBar = Application.GetOption("Show Status Bar")
' show status bar
Application.SetOption "Show Status Bar", True
'The call can not have a trailing slash, so
'strip it from the path if present
sPath = UnqualifyPath((CurrentProject.Path))
sPath = GetFolder(sPath )
strSaveFileName = ""
Me.Repaint
If Len(Trim(sPath)) > 0 Then
Select Case Me.lstForm 'name of report or query from list box
Case "Statement Monthly Summary-pwk"
'see "syscmd" in Help
Application.SysCmd acSysCmdSetStatus, "Exporting: Statement Monthly Summary"
strSaveFileName = sPath & "\Statement Monthly Summary " & Me.cboMonth & " " & Me.cboYear & " Hours.xls"
DoCmd.OutputTo acOutputQuery, "EQ_StatementMonthlySummary", acFormatXLS, strSaveFileName, False
' Edit the Excel workbook - add rows at top, create column totals
Call EditVendorWkSht(strSaveFileName, "Statement Monthly Summary", Me.cboMonth & " " & Me.cboYear & " Hours")
Case xxxx
<snip>
.
.
<snip>
End Select
' clear status bar message
Application.SysCmd acSysCmdClearStatus
' set status bar visible state to original state
If Not bStatusBar Then
Application.SetOption "Show Status Bar", False
End If
If Len(Trim(strSaveFileName)) > 0 Then
If Me.lstForm = "AllVendorReports" Then
MsgBox "Done!!" & vbCrLf & vbCrLf & "The files were saved in " & sPath
Else
MsgBox "Done!!" & vbCrLf & vbCrLf & "The file was saved as: " & strSaveFileName
End If
End If
Else
MsgBox "Export Canceled"
End If
Exit_cmdExportData_Click:
Exit Sub
Err_cmdExportData_Click:
MsgBox Err.Description
Resume Exit_cmdExportData_Click
End Sub
'-----------------------------------------------------
Public Function UnqualifyPath(psPath As String) As String
'Qualifying a path involves assuring that its format
'is valid, including a trailing slash, ready for a
'filename. Since SHBrowseForFolder will not pre-select
'the path if it contains the trailing slash, it must be
'removed, hence 'unqualifying' the path.
If Len(psPath) > 0 Then
If Right$(psPath, 1) = "\" Then
UnqualifyPath = Left$(psPath, Len(psPath) - 1)
Exit Function
End If
End If
UnqualifyPath = psPath
End Function
Clear as mud?
Post back with your code if you get stuck .....