Have Save Dialog Box Appear with a preset folder and file type

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]

I have taken the liberty of posting the code I use to save e-mail messages. I have added in the code to display the saveas dialog set with the filename, though it works transparently without, if you restore the commented out section and comment out the saveas dialog section, and does not overwrite existing files of the same name. Unlike your version it does not add the date to the filename. Because of the unique filename function the date is not required, though you can add it if you wish.

It also removes illegal characters from the derived filename.

You may find some of the functiuons useful in other projects. The code does not require an Outlook VBA library reference to Word as it uses late binding to Word.

If the H drive (strPath) is not present, the macro will display a warning message box and the process will end.

Code:

---

Option Explicit
Private wdApp As Object
Private wdDoc As Object
Private bStarted As Boolean
Const strPath As String = "H:\Uploads\"

Sub SaveSelectedMessagesAsPDF()
'Select the messages to process and run this macro
Dim olMsg As MailItem
    'Create the folder to store the messages if not present
    If CreateFolders(strPath) = False Then GoTo lbl_Exit
    'Open or Create a Word object
    On Error Resume Next
    Set wdApp = GetObject(, "Word.Application")
    If Err Then
        Set wdApp = CreateObject("Word.Application")
        bStarted = True
    End If
    On Error GoTo 0
    For Each olMsg In Application.ActiveExplorer.Selection
        SaveAsPDFfile olMsg
    Next olMsg
lbl_Exit:
    If bStarted Then wdApp.Quit
    Set wdApp = Nothing
    Exit Sub
End Sub

Sub SaveAsPDFfile(olItem As MailItem)
Dim olNS As NameSpace
Dim FSO As Object, TmpFolder As Object
Dim tmpPath As String
Dim strFileName As String
Dim strName As String
Dim oRegEx As Object

    Set olNS = Application.GetNamespace("MAPI")

    'Get the user's TempFolder to store the temporary file
    Set FSO = CreateObject("Scripting.FileSystemObject")
    tmpPath = FSO.GetSpecialFolder(2)

    'construct the filename for the temp mht-file
    strName = "email_temp.mht"
    tmpPath = tmpPath & "\" & strName

    'Save temporary file
    olItem.SaveAs tmpPath, 10

    'Open the temporary file in Word
    Set wdDoc = wdApp.Documents.Open(Filename:=tmpPath, _
                                    AddToRecentFiles:=False, _
                                    Visible:=False, _
                                    Format:=7)

    'Create a file name from the message subject
    strFileName = olItem.Subject
    'Remove illegal filename characters
    Set oRegEx = CreateObject("vbscript.regexp")
    oRegEx.Global = True
    oRegEx.Pattern = "[\/:*?""<>|]"
    strFileName = Trim(oRegEx.Replace(strFileName, "")) & ".pdf"
    strFileName = FileNameUnique(strPath, strFileName, "pdf")
    strFileName = strPath & strFileName

    'Save As pdf
    With wdApp.Dialogs(84)
        .Name = strFileName
        .Format = 17
        .addtomru = False
        .Show
    End With
    'wdDoc.ExportAsFixedFormat OutputFileName:= _
    strFileName, _
    ExportFormat:=17, _
    OpenAfterExport:=False, _
    OptimizeFor:=0, _
    Range:=0, _
    From:=0, _
    To:=0, _
    Item:=0, _
    IncludeDocProps:=True, _
    KeepIRM:=True, _
    CreateBookmarks:=0, _
    DocStructureTags:=True, _
    BitmapMissingFonts:=True, _
    UseISO19005_1:=False

    ' close the document and Word
    wdDoc.Close 0
    'Cleanup
    Set olNS = Nothing
    Set olItem = Nothing
    Set wdDoc = Nothing
    Set oRegEx = Nothing
lbl_Exit:
    Exit Sub
End Sub

Private Function CreateFolders(strPath As String) As Boolean
Dim strTempPath As String
Dim lngPath As Long
Dim vPath As Variant
    vPath = Split(strPath, "\")
    strPath = vPath(0) & "\"
    For lngPath = 1 To UBound(vPath)
        strPath = strPath & vPath(lngPath) & "\"
        On Error GoTo Err_Handler
        If Not FolderExists(strPath) Then MkDir strPath
    Next lngPath
    CreateFolders = True
lbl_Exit:
    Exit Function
Err_Handler:
    MsgBox "The path " & strPath & " is invalid!"
    CreateFolders = False
    Resume lbl_Exit
End Function

Private Function FileNameUnique(strPath As String, _
                              strFileName As String, _
                              strExtension As String) As String
Dim lngF As Long
Dim lngName As Long
    lngF = 1
    lngName = Len(strFileName) - (Len(strExtension) + 1)
    strFileName = Left(strFileName, lngName)
    Do While FileExists(strPath & strFileName & Chr(46) & strExtension) = True
        strFileName = Left(strFileName, lngName) & "(" & lngF & ")"
        lngF = lngF + 1
    Loop
    FileNameUnique = strFileName & Chr(46) & strExtension
lbl_Exit:
    Exit Function
End Function

Private Function FolderExists(ByVal PathName As String) As Boolean
Dim nAttr As Long
    On Error GoTo NoFolder
    nAttr = GetAttr(PathName)
    If (nAttr And vbDirectory) = vbDirectory Then
        FolderExists = True
    End If
NoFolder:
    Exit Function
End Function

Private Function FileExists(ByVal Filename As String) As Boolean
Dim nAttr As Long
    On Error GoTo NoFile
    nAttr = GetAttr(Filename)
    If (nAttr And vbDirectory) <> vbDirectory Then
        FileExists = True
    End If
NoFile:
    Exit Function
End Function

---

Thank you for the help, I modified what you provided slightly as I found I could use an input box to create the file name, so they do not need the Save As window.

Code:

---

Option Explicit
Private wdApp As Object
Private wdDoc As Object
Private bStarted As Boolean
Const strPath As String = "H:\Uploads\"
 
 Public Function InPBox() As String
 Dim strfilename As String
 
InPBox = InputBox("Please enter the account number", "Account Number")
strfilename = InPBox
 End Function
Sub SaveSelectedMessagesAsPDF1()
'Select the messages to process and run this macro
Dim olMsg As MailItem
    'Create the folder to store the messages if not present
    If CreateFolders(strPath) = False Then GoTo lbl_Exit
    'Open or Create a Word object
    On Error Resume Next
    Set wdApp = GetObject(, "Word.Application")
    If Err Then
        Set wdApp = CreateObject("Word.Application")
        bStarted = True
    End If
    On Error GoTo 0
    For Each olMsg In Application.ActiveExplorer.Selection
        SaveAsPDFfile olMsg
    Next olMsg
lbl_Exit:
    If bStarted Then wdApp.Quit
    Set wdApp = Nothing
    Exit Sub
End Sub
 
Sub SaveAsPDFfile(olItem As MailItem)
Dim olNS As NameSpace
Dim FSO As Object, TmpFolder As Object
Dim tmpPath As String
Dim strfilename As String
Dim strName As String
Dim oRegEx As Object
 
    Set olNS = Application.GetNamespace("MAPI")
 
    'Get the user's TempFolder to store the temporary file
    Set FSO = CreateObject("Scripting.FileSystemObject")
    tmpPath = FSO.GetSpecialFolder(2)
 
    'construct the filename for the temp mht-file
    strName = "email_temp.mht"
    tmpPath = tmpPath & "\" & strName
 
    'Save temporary file
    olItem.SaveAs tmpPath, 10
 
    'Open the temporary file in Word
    Set wdDoc = wdApp.Documents.Open(Filename:=tmpPath, _
                                    AddToRecentFiles:=False, _
                                    Visible:=False, _
                                    Format:=7)
 
    'Create a file name from the message subject
    'strFileName = olItem.subject
  strfilename = InPBox
    'Remove illegal filename characters
    Set oRegEx = CreateObject("vbscript.regexp")
    oRegEx.Global = True
    oRegEx.Pattern = "[\/:*?""<>|]"
    strfilename = Trim(oRegEx.Replace(strfilename, "")) & ".pdf"
    strfilename = FileNameUnique(strPath, strfilename, "pdf")
    strfilename = strPath & Format(Date, "mmmm dd, yyyy") & "\" & strfilename
 
    'Save As pdf
 '  With wdApp.Dialogs(84)
    '  .Name = strFileName
      '  .Format = 17
      ' .addtomru = False
        '.Show
    'End With
  wdDoc.ExportAsFixedFormat OutputFileName:= _
    strfilename, _
    ExportFormat:=17, _
    OpenAfterExport:=False, _
    OptimizeFor:=0, _
    Range:=0, _
    From:=0, _
    To:=0, _
    Item:=0, _
    IncludeDocProps:=True, _
    KeepIRM:=True, _
    CreateBookmarks:=0, _
    DocStructureTags:=True, _
    BitmapMissingFonts:=True, _
    UseISO19005_1:=False
 
    ' close the document and Word
    wdDoc.Close 0
  Dim objOL As Outlook.Application
Dim objMsg As Outlook.MailItem 'Object
Dim objAttachments As Outlook.Attachments
Dim objSelection As Outlook.Selection
Dim i As Long
'Dim FSO As Object,
Dim tmpfilename As Object
 
ExitSub:
 
Set objAttachments = Nothing
Set objMsg = Nothing
Set objSelection = Nothing
Set objOL = Nothing
    'Cleanup
    Set olNS = Nothing
    Set olItem = Nothing
    Set wdDoc = Nothing
    Set oRegEx = Nothing
lbl_Exit:
    Exit Sub
End Sub
 
Private Function CreateFolders(strPath As String) As Boolean
Dim strTempPath As String
Dim lngPath As Long
Dim vPath As Variant
    vPath = Split(strPath, "\")
    strPath = vPath(0) & "\"
    For lngPath = 1 To UBound(vPath)
        strPath = strPath & Format(Date, "mmmm dd, yyyy") & "\" & vPath(lngPath) & "\"
        On Error GoTo Err_Handler
      '  If Not FolderExists(strPath) Then MkDir strPath
      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
    Next lngPath
    CreateFolders = True
lbl_Exit:
    Exit Function
Err_Handler:
    MsgBox "The path " & strPath & " is invalid!"
    CreateFolders = False
    Resume lbl_Exit
End Function
 
Private Function FileNameUnique(strPath As String, _
                              strfilename As String, _
                              strextension As String) As String
Dim lngF As Long
Dim lngName As Long
    lngF = 1
    lngName = Len(strfilename) - (Len(strextension) + 1)
    strfilename = Left(strfilename, lngName)
    Do While FileExists(strPath & Format(Date, "mmmm dd, yyyy") & "\" & strfilename & Chr(46) & strextension) = True
        strfilename = Left(strfilename, lngName) & "(" & lngF & ")"
        lngF = lngF + 1
    Loop
    FileNameUnique = strfilename & Chr(46) & strextension
lbl_Exit:
    Exit Function
End Function
 
Private Function FolderExists(ByVal PathName As String) As Boolean
Dim nAttr As Long
    On Error GoTo NoFolder
    nAttr = GetAttr(PathName)
    If (nAttr And vbDirectory) = vbDirectory Then
        FolderExists = True
    End If
NoFolder:
    Exit Function
End Function
 
Private Function FileExists(ByVal Filename As String) As Boolean
Dim nAttr As Long
    On Error GoTo NoFile
    nAttr = GetAttr(Filename)
    If (nAttr And vbDirectory) <> vbDirectory Then
        FileExists = True
    End If
NoFile:
    Exit Function
End Function

---

I also found a macro that I would like to run along with this one, that will save the attachments, and I would want them to have the same name that was added in the input box, but I'm pretty new at this and can't seem to get it to work. I would like it to follow the same naming convention as above (regarding duplicate file names) how can I get the 2 macros to work together?

Code:

---

Public Sub SaveAttachments()
Dim objOL As Outlook.Application
Dim objMsg As Outlook.MailItem 'Object
Dim objAttachments As Outlook.Attachments
Dim objSelection As Outlook.Selection
Dim i As Long
Dim FSO As Object
Dim lngCount As Long
Dim strFile As String
Dim strFolderpath As String
Dim strDeletedFiles As String
Set FSO = CreateObject("Scripting.FileSystemObject")
Set tmpfilename = FSO.GetSpecialFolder(2)
Dim body As String
 
' Get the path to your My Documents folder
'strFolderpath = CreateObject("WScript.Shell").SpecialFolders(16)
'On Error Resume Next
 
' Instantiate an Outlook Application object.
 
Set objOL = CreateObject("Outlook.Application")
 
' Get the collection of selected objects.
Set objSelection = objOL.ActiveExplorer.Selection
 
 
' Set the Attachment folder.
strFolderpath = "H:\Uploads\" & Format(Date, "mmmm dd, yyyy") & "\"
 
' Check each selected item for attachments. If attachments exist,
' save them to the strFolderPath folder and strip them from the item.
For Each objMsg In objSelection
 
' This code only strips attachments from mail items.
' If objMsg.class=olMail Then
' Get the Attachments collection of the item.
Set objAttachments = objMsg.Attachments
lngCount = objAttachments.Count
strDeletedFiles = ""
 
If lngCount = 0 Then Exit Sub
If lngCount > 0 Then
 
' We need to use a count down loop for removing items
' from a collection. Otherwise, the loop counter gets
' confused and only every other item is removed.
 
 
 
 For i = lngCount To 1 Step -1
  If objAttachments.Item(i).Size > 20000 Then
 
    ' Save attachment before deleting from item.
    ' Get the file name.
    strFile = objAttachments.Item(i).Filename
 
    ' Combine with the path to the Temp folder.
    strFile = strFolderpath & strFile
 
If FSO.FileExists(strFile) Then
    strFile = objAttachments.Item(i).Filename
    strFile = strFolderpath & " " & Format(Now, "hh.mm AM/PM") & " " & strFile
  End If
 
    ' Save the attachment as a file.
    objAttachments.Item(i).SaveAsFile strFile
 
    ' Delete the attachment.
  ' objAttachments.Item(i).Delete
 
    'write the save as path to a string to add to the message
    'check for html and use html tags in link
  ' If objMsg.BodyFormat <> olFormatHTML Then
      '  strDeletedFiles = strDeletedFiles & vbCrLf & "<file://" & strFile & ">"
    '  Else
      ' strDeletedFiles = strDeletedFiles & "<br>" & "<a href='file://" & _
        strFile & "'>" & strFile & "</a>"
  ' End If
 
    'Use the MsgBox command to troubleshoot. Remove it from the final code.
    'MsgBox strDeletedFiles
End If
 
Next i
 
' Adds the filename string to the message body and save it
' Check for HTML body
 
If objMsg.BodyFormat <> olFormatHTML Then
    objMsg.body = vbCrLf & strDeletedFiles & vbCrLf & objMsg.body
Else
    objMsg.HTMLBody = "<p>" & strDeletedFiles & "</p>" & objMsg.HTMLBody
End If
  objMsg.Save
End If
Next
 
ExitSub:
 
Set objAttachments = Nothing
Set objMsg = Nothing
Set objSelection = Nothing
Set objOL = Nothing
End Sub

---

[/QUOTE]

While it is not especially difficult to add the extraction of attachments to my earlier macro set, saving the attachments with the same name presents something of a problem. If you want to associate the attachments with the message, then you can use the account number, input from your inputbox as a prefix to the attachment names. I would also suggest putting the attachments in a sub folder as in the following example, which calls the extraction routine from the save to PDF function.

Frankly I don't see any advantage in using the input box, and if the account number is going to be in the subject anyway, then any prompt for a name you already have is a distraction, but I have included it.

Code:

---

Option Explicit
Private wdApp As Object
Private wdDoc As Object
Private bStarted As Boolean
Const strPath As String = "H:\Uploads\"

Sub SaveSelectedMessagesAsPDF()
'Select the messages to process and run this macro
Dim olMsg As MailItem
    'Create the folder to store the messages if not present
    If CreateFolders(strPath) = False Then GoTo lbl_Exit
    'Open or Create a Word object
    On Error Resume Next
    Set wdApp = GetObject(, "Word.Application")
    If Err Then
        Set wdApp = CreateObject("Word.Application")
        bStarted = True
    End If
    On Error GoTo lbl_Exit:
    For Each olMsg In Application.ActiveExplorer.Selection
        SaveAsPDFfile olMsg, wdApp
    Next olMsg
lbl_Exit:
    If bStarted Then wdApp.Quit
    Set wdApp = Nothing
    Exit Sub
End Sub

Sub SaveAsPDFfile(olItem As MailItem, wdApp As Object)
Dim FSO As Object, TmpFolder As Object
Dim tmpPath As String
Dim strFileName As String
Dim strAttachPrefix As String
Dim strName As String
Dim oRegEx As Object

    'Get the user's TempFolder to store the temporary file
    Set FSO = CreateObject("Scripting.FileSystemObject")
    tmpPath = FSO.GetSpecialFolder(2)

    'construct the filename for the temp mht-file
    strName = "email_temp.mht"
    tmpPath = tmpPath & "\" & strName

    'Save temporary file
    olItem.SaveAs tmpPath, 10

    'Open the temporary file in Word
    Set wdDoc = wdApp.Documents.Open(Filename:=tmpPath, _
                                    AddToRecentFiles:=False, _
                                    Visible:=False, _
                                    Format:=7)

    'Create a file name from the message subject
    strFileName = InputBox("Enter account number for message" & vbCr & _
    olItem.Subject, "Account Number")
    If strFileName = "" Then GoTo lbl_Exit
   
    'Remove illegal filename characters
    Set oRegEx = CreateObject("vbscript.regexp")
    oRegEx.Global = True
    oRegEx.Pattern = "[\/:*?""<>|]"
    strFileName = Trim(oRegEx.Replace(strFileName, "")) & ".pdf"
    strFileName = FileNameUnique(strPath, strFileName, "pdf")
    strAttachPrefix = Replace(strFileName, ".pdf", "")
    'save attachments
    SaveAttachments olItem, strAttachPrefix
    strFileName = strPath & strFileName

    'Save As pdf
    wdDoc.ExportAsFixedFormat OutputFileName:= _
    strFileName, _
    ExportFormat:=17, _
    OpenAfterExport:=False, _
    OptimizeFor:=0, _
    Range:=0, _
    From:=0, _
    To:=0, _
    Item:=0, _
    IncludeDocProps:=True, _
    KeepIRM:=True, _
    CreateBookmarks:=0, _
    DocStructureTags:=True, _
    BitmapMissingFonts:=True, _
    UseISO19005_1:=False
       
    ' close the document and Word
lbl_Exit:
    wdDoc.Close 0
    Set wdDoc = Nothing
    Set oRegEx = Nothing
    Exit Sub
End Sub

Private Sub SaveAttachments(olItem As MailItem, strName As String)
Dim olAttach As Attachment
Dim strFname As String
Dim strExt As String
Dim strSaveFldr As String
   
    strSaveFldr = strPath & "Attachments\"
    CreateFolders strSaveFldr
    On Error GoTo lbl_Exit
    If olItem.Attachments.Count > 0 Then
        For Each olAttach In olItem.Attachments
            If Not olAttach.Filename Like "image*.*" Then
                strFname = strName & "_" & olAttach.Filename
                strExt = Right(strFname, Len(strFname) - InStrRev(strFname, Chr(46)))
                strFname = FileNameUnique(strSaveFldr, strFname, strExt)
                olAttach.SaveAsFile strSaveFldr & strFname
            End If
        Next olAttach
    End If
lbl_Exit:
    Set olAttach = Nothing
    Exit Sub
End Sub

Private Function CreateFolders(strPath As String) As Boolean
Dim strTempPath As String
Dim lngPath As Long
Dim vPath As Variant
    vPath = Split(strPath, "\")
    strPath = vPath(0) & "\"
    For lngPath = 1 To UBound(vPath)
        strPath = strPath & vPath(lngPath) & "\"
        On Error GoTo Err_Handler
        If Not FolderExists(strPath) Then MkDir strPath
    Next lngPath
    CreateFolders = True
lbl_Exit:
    Exit Function
Err_Handler:
    MsgBox "The path " & strPath & " is invalid!"
    CreateFolders = False
    Resume lbl_Exit
End Function

Private Function FileNameUnique(strPath As String, _
                              strFileName As String, _
                              strExtension As String) As String
Dim lngF As Long
Dim lngName As Long
    lngF = 1
    lngName = Len(strFileName) - (Len(strExtension) + 1)
    strFileName = Left(strFileName, lngName)
    Do While FileExists(strPath & strFileName & Chr(46) & strExtension) = True
        strFileName = Left(strFileName, lngName) & "(" & lngF & ")"
        lngF = lngF + 1
    Loop
    FileNameUnique = strFileName & Chr(46) & strExtension
lbl_Exit:
    Exit Function
End Function

Private Function FolderExists(ByVal PathName As String) As Boolean
Dim nAttr As Long
    On Error GoTo NoFolder
    nAttr = GetAttr(PathName)
    If (nAttr And vbDirectory) = vbDirectory Then
        FolderExists = True
    End If
NoFolder:
    Exit Function
End Function

Private Function FileExists(ByVal Filename As String) As Boolean
Dim nAttr As Long
    On Error GoTo NoFile
    nAttr = GetAttr(Filename)
    If (nAttr And vbDirectory) <> vbDirectory Then
        FileExists = True
    End If
NoFile:
    Exit Function
End Function

---