Hello,

I am using the code below to save the selected email as a PDF. Currently the save name is taken from the Subject of the email. I would like to give the user the ability to choose the save name, but would like the save dialog box to appear and default to the directory created in the macro, and have PDF as the file type. Is that possible, or am I just hoping for too much? I am using Office 2010

[VBA]
Sub SaveMessageAsPDF()

Dim Selection As Selection
Dim obj As Object
Dim Item As MailItem


Dim wrdApp As Word.Application
Dim wrdDoc As Word.Document
Set wrdApp = CreateObject("Word.Application")
Set Selection = Application.ActiveExplorer.Selection

For Each obj In Selection

Set Item = obj

Dim FSO As Object, TmpFolder As Object
Dim sName As String
Set FSO = CreateObject("Scripting.FileSystemObject")
Set tmpFileName = FSO.GetSpecialFolder(2)

sName = Item.Subject
ReplaceCharsForFileName sName, "-"
tmpFileName = tmpFileName & "\" & sName & ".mht"

Item.SaveAs tmpFileName, olMHTML


Set wrdDoc = wrdApp.Documents.Open(FileName:=tmpFileName, Visible:=True)

Dim WshShell As Object
Dim SpecialPath As String
Dim strToSaveAs As String
Set WshShell = CreateObject("WScript.Shell")
MyDocs = WshShell.SpecialFolders(16)


If Len(Dir("H:\Uploads\", vbDirectory)) = 0 Then
MkDir "H:\Uploads\"
End If
If Len(Dir("H:\Uploads\" & Format(Date, "mmmm dd, yyyy"), vbDirectory)) = 0 Then
MkDir "H:\Uploads\" & Format(Date, "mmmm dd, yyyy")
End If
strToSaveAs = "H:\Uploads\" & Format(Date, "mmmm dd, yyyy") & "\" & sName & ".pdf"

' check for duplicate filenames
' if matched, add the current time to the file name
If FSO.FileExists(strToSaveAs) Then
sName = " " & Format(Now, "hh.mm AM/PM") & " " & sName
strToSaveAs = "H:\Uploads\" & Format(Date, "mmmm dd, yyyy") & "\" & sName & ".pdf"
End If

wrdApp.ActiveDocument.ExportAsFixedFormat OutputFileName:= _
strToSaveAs, ExportFormat:=wdExportFormatPDF, _
OpenAfterExport:=False, OptimizeFor:=wdExportOptimizeForPrint, _
Range:=wdExportAllDocument, From:=0, To:=0, Item:= _
wdExportDocumentContent, IncludeDocProps:=True, KeepIRM:=True, _
CreateBookmarks:=wdExportCreateNoBookmarks, DocStructureTags:=True, _
BitmapMissingFonts:=True, UseISO19005_1:=False



Next obj
wrdDoc.Close
wrdApp.Quit
Set wrdDoc = Nothing
Set wrdApp = Nothing
Set WshShell = Nothing
Set obj = Nothing
Set Selection = Nothing
Set Item = Nothing

End Sub
[/VBA]