Terry -
You should probably use GetSaveAsFileName. What this does is present the
Save As dialog to the user, and it gets the name and path that the user
wants. It does not save any files, so you have to do that. But it is
more flexible.
This example is a routine to export a chart, which makes use of
GetSaveAsFileName. It has some code to check for a duplicate file name,
but you could leave some of that out on its own.
'=========================================================================
Sub ExportChart()
Dim sChartName As String
Dim sFileName As String
Dim sPathName As String
Dim sPrompt As String
Dim sCurDir As String
Dim iOverwrite As Long
If ActiveSheet Is Nothing Then GoTo ExitSub
If ActiveChart Is Nothing Then GoTo ExitSub
' save current directory, restore it later
sCurDir = CurDir
' change to desired directory
' (in this case, active workbook's directory)
sPathName = ActiveWorkbook.Path
If Len(sPathName) > 0 Then
ChDrive sPathName
ChDir sPathName
End If
' proposed file name
sFileName = "MyChart.png"
' loop until unique name is entered
Do
sChartName = Application.GetSaveAsFilename(sFileName, _
"All Files (*.*),*.*", , _
"Browse to a folder and enter a file name")
If Len(sChartName) = 0 Then GoTo ExitSub
If sChartName = "False" Then GoTo ExitSub
' make sure valid filter (extension) is used
Select Case True
Case UCase$(Right(sChartName, 4)) = ".PNG"
Case UCase$(Right(sChartName, 4)) = ".GIF"
Case UCase$(Right(sChartName, 4)) = ".JPG"
Case UCase$(Right(sChartName, 4)) = ".JPE"
Case UCase$(Right(sChartName, 5)) = ".JPEG"
Case Else
If Right$(sChartName, 1) <> "." Then
sChartName = sChartName & "."
End If
sChartName = sChartName & "png"
End Select
' unique name - okay to save it
If Not FileExists(sChartName) Then Exit Do
' tell user that the filename is in use
' parse filename
sFileName = FullNameToFileName(sChartName)
sPathName = FullNameToPath(sChartName)
' construct message
sPrompt = "A file named '" & sFileName & "' already exists in '" _
& sPathName & "'"
sPrompt = sPrompt & vbNewLine & vbNewLine & _
"Do you want to overwrite the existing file?"
' ask user what to do
iOverwrite = MsgBox(sPrompt, vbYesNoCancel + vbQuestion, _
"Image File Exists")
Select Case iOverwrite
Case vbYes
' overwrite existing file
Exit Do
Case vbNo
' do nothing, loop again to get new filename
Case vbCancel
' bail out
GoTo ExitSub
End Select
Loop
' finally, save the file using filename from above
ActiveChart.Export sChartName
ExitSub:
' restore previous current directory
ChDrive sCurDir
ChDir sCurDir
End Sub
'=========================================================================
Function FileExists(ByVal FileSpec As String) As Boolean
' Karl Peterson MS VB MVP
Dim Attr As Long
' Guard against bad FileSpec by ignoring errors
' retrieving its attributes.
On Error Resume Next
Attr = GetAttr(FileSpec)
If Err.Number = 0 Then
' No error, so something was found.
' If Directory attribute set, then not a file.
FileExists = Not ((Attr And vbDirectory) = vbDirectory)
End If
End Function
'=========================================================================
Function FullNameToFileName(sFullName As String) As String
Dim k As Integer
Dim sTest As String
If InStr(1, sFullName, "[") > 0 Then
k = InStr(1, sFullName, "[")
sTest = Mid(sFullName, k + 1, InStr(1, sFullName, "]") - k - 1)
Else
For k = Len(sFullName) To 1 Step -1
If Mid(sFullName, k, 1) = "\" Then Exit For
Next k
sTest = Mid(sFullName, k + 1, Len(sFullName) - k)
End If
FullNameToFileName = sTest
End Function
'=========================================================================
Function FullNameToPath(sFullName As String) As String
''' does not include trailing backslash
Dim k As Integer
For k = Len(sFullName) To 1 Step -1
If Mid(sFullName, k, 1) = "\" Then Exit For
Next k
If k < 1 Then
FullNameToPath = ""
Else
FullNameToPath = Mid(sFullName, 1, k - 1)
End If
End Function
'=========================================================================
- Jon
-------
Jon Peltier
Peltier Technical Services, Inc.
http://peltiertech.com/
terry said:
hi Tom - thanks for replying. This code works very well, but it
actually goes ahead and Saves before the user has a chance to change
the suggested values in the 'Save In' and 'File Name' drop-down
boxes. I was hoping to show the Save As Dialog with these boxes
filled in, but give the user the option to make changes before
clicking Save. I've noticed that...
Application.Dialogs(xlDialogSaveAs).Show strFileName
will show the dialog box this way, waiting for the user to click Save
or Cancel. I just can't get the 'Save In' drop-down box to show the
value of strSaveLocation.
Terry W
:
If the file path & name are already established, why show a Save As
dialog? You can do the Save As directly:
ActiveWorkbook.SaveAs Filename:=strSaveLocation & "\" & strFileName, _
FileFormat:=xlExcel8, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
Hope this helps,
Hutch
:
hello gurus
I'm having trouble with the following code. The last line I've show
works perfectly - the 'Save As' dialog comes up, and the 'File Name'
drop-down box correctly shows the value of strFileName. But, I
can't figure out how to get the 'Save In' drop down box to show the
value of strSaveLocation.
strSaveLocation = "C:\EmpData\2009"
strFileName = "Report_" & strDate & "_" & strEmpName & ".xls"
Application.Dialogs(xlDialogSaveAs).Show strFileName
Any clues welcomed!
Terry W.
