Save An Email As PDF Without Displaying SaveAs Dialog Box - vba

Question

I have an Outlook macro that saves an email as a PDF. It is passed the name of the file (EmailName) from the subject\input box and the folder (strFolder) to save to.
I am using PDFTK to create the PDF.
I show the SaveAs dialog box to save.
If dlgSaveAs.Show = -1 Then
strCurrentFile = dlgSaveAs.SelectedItems(1)
Is there a way of saving the email as PDF without showing the SaveAs dialog box to confirm the file name\folder?
----------------------------------------------------------------------------
Public Function EVAL_SaveAsPDFfile(EmailName As String, strFolder As String) As String
'====================================================
' Description: Outlook macro to save a selected item in the pdf-format
' Requires Word 2007 SP2 or Word 2010
' Requires a reference to "Microsoft Word Object Library"
' (version is 12.0 or 14.0)
' In VBA Editor; Tools-> References...
'====================================================
' also microsoft shell controls and automation
'=============================================
' set share location
'=============================================
' On Error GoTo ErrorHandling
'Root folder
Dim strTempFileName As String
strTempFileName = "\\asfs1\cons\clients"
If (Right(strFolder, 1) = "\") Then
Else
strFolder = strFolder + "\"
End If
'PDFTK
Dim program As String
program = strTempFileName & "\crm\pdftk.exe"
Dim directoremail As String
directoremail = "email#address.co.uk"
FUNC_SYSTEM_FolderExistsCreate (strFolder)
FUNC_SYSTEM_FolderExistsCreate (strTempFileName)
Set FSO = CreateObject("Scripting.FileSystemObject")
If FSO.FolderExists(strTempFileName) Then
'Get all selected items
Dim MyOlNamespace As Outlook.NameSpace
Set MyOlNamespace = Application.GetNamespace("MAPI")
Set MyOlSelection = Application.ActiveExplorer.Selection
'Make sure at least one item is selected
If MyOlSelection.Count <> 1 Then
Response = MsgBox("Please select a single item", vbExclamation, "Save as PDF")
Exit Function
End If
'Retrieve the selected item
Set MySelectedItem = MyOlSelection.Item(1)
'Get the user's TempFolder to store the item in
Dim tmpString As String
Dim tmpFileName As String, newFileName As String
tmpString = strTempFileName & "\crm\temp\" & Format(Now, "yyyyMMddHHmmss")
'construct the filename for the temp mht-file
tmpFileName = tmpString & ".mht"
'newFileName = tmpString & ".pdf"
newFileName = EmailName & ".pdf"
'Save the mht-file
MySelectedItem.SaveAs tmpFileName, olMHTML
'Create a Word object
Dim wrdApp As Word.Application
Dim wrdDoc As Word.document
Set wrdApp = CreateObject("Word.Application")
'Open the mht-file in Word without Word visible
Set wrdDoc = wrdApp.Documents.Open(FileName:=tmpFileName, Visible:=False)
'Define the SafeAs dialog
Dim dlgSaveAs As FileDialog
Set dlgSaveAs = wrdApp.FileDialog(msoFileDialogSaveAs)
'Determine the FilterIndex for saving as a pdf-file
'Get all the filters
Dim fdfs As FileDialogFilters
Dim fdf As FileDialogFilter
Set fdfs = dlgSaveAs.Filters
'Loop through the Filters and exit when "pdf" is found
Dim i As Integer
i = 0
For Each fdf In fdfs
i = i + 1
If InStr(1, fdf.Extensions, "pdf", vbTextCompare) > 0 Then
Exit For
End If
Next fdf
'Set the FilterIndex to pdf-files
dlgSaveAs.FilterIndex = i
'Get location of My Documents folder
Dim WshShell As Object
Dim SpecialPath As String
Set WshShell = CreateObject("WScript.Shell")
SpecialPath = WshShell.SpecialFolders(16)
'Construct a safe file name from the message subject
Dim msgFileName As String
msgFileName = MySelectedItem.subject
Set oRegEx = CreateObject("vbscript.regexp")
oRegEx.Global = True
oRegEx.Pattern = "[\\/:*?""<>|]"
msgFileName = Trim(oRegEx.Replace(msgFileName, ""))
'Set the initial location and file name for SaveAs dialog
'=============================================
' set default location
'=============================================
Dim strCurrentFile As String
If (TypeOf MyOlSelection.Item(1) Is Outlook.mailitem) Then
strCurrentFile = GetClientFolder(MyOlSelection.Item(1))
End If
If strCurrentFile = vbNullString Then
dlgSaveAs.InitialFileName = strFolder
Else
If FileFolderExists(strCurrentFile & "\") Then
dlgSaveAs.InitialFileName = strCurrentFile & "\"
Else
dlgSaveAs.InitialFileName = strFolder
End If
End If
dlgSaveAs.Execute
Set objFSO = CreateObject("Scripting.FileSystemObject")
' minimize outlook to show save as dialog
Set OutlookObj = GetObject(, "Outlook.Application")
OutlookObj.ActiveExplorer.WindowState = olMinimized
Dim objShell As Shell
Set objShell = New Shell
'' objShell.MinimizeAll
'Show the SaveAs dialog and save the message as pdf
newFileName = Replace(newFileName, ":", " -", Start:=1)
dlgSaveAs.InitialFileName = strFolder + newFileName
dlgSaveAs.Execute
If dlgSaveAs.Show = -1 Then
strCurrentFile = dlgSaveAs.SelectedItems(1)
'Verify if pdf is selected
If Right(strCurrentFile, 4) <> ".pdf" Then
Response = MsgBox("Sorry, only saving in the pdf-format is supported." & vbNewLine & vbNewLine & "Save as PDF instead?", vbInformation + vbOKCancel)
If Response = vbCancel Then
' wrdDoc.Close
' wrdApp.Quit
Exit Function
ElseIf Response = vbOK Then
intPos = InStrRev(strCurrentFile, ".")
If intPos > 0 Then
strCurrentFile = Left(strCurrentFile, intPos - 1)
End If
strCurrentFile = strCurrentFile & ".pdf"
End If
End If
'Save as pdf
wrdApp.ActiveDocument.ExportAsFixedFormat OutputFileName:=newFileName, 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
EVAL_SaveAsPDFfile = strCurrentFile
' now append the temp file with the chosen one
'=============================================
' set pdftk location
'=============================================
Dim tempPDF
tempPDF = tmpString & " temp.pdf"
' if existing file, append to old
If objFSO.FileExists(strCurrentFile) Then
Dim command As String
command = Chr(34) & program & Chr(34) & " " & Chr(34) & newFileName & Chr(34) & " " & Chr(34) & strCurrentFile & Chr(34) & " cat output " & Chr(34) & tempPDF & Chr(34)
Dim oShell
Set oShell = CreateObject("WScript.Shell")
fdsk = oShell.Run(command, 1, True)
Set oShell = Nothing
' MsgBox ("Temp: " & tempPDF + ", Current: " & strCurrentFile)
objFSO.CopyFile tempPDF, strCurrentFile, True
Else
' create file to be overwriten
Dim fsonewpdf As Object
Set fsonewpdf = CreateObject("Scripting.FileSystemObject")
Dim oFile As Object
Set oFile = fsonewpdf.CreateTextFile(strCurrentFile)
oFile.WriteLine "test"
oFile.Close
Set fsonewpdf = Nothing
Set oFile = Nothing
objFSO.CopyFile newFileName, strCurrentFile, True
End If
'copy new file to saveas file
'delete temp files
If objFSO.FileExists(tempPDF) Then
objFSO.DeleteFile tempPDF
End If
If objFSO.FileExists(newFileName) Then
objFSO.DeleteFile newFileName
End If
'close the document and Word
wrdDoc.Close
'wrdApp.Quit
If objFSO.FileExists(tmpFileName) Then
objFSO.DeleteFile tmpFileName
End If
Else
' close the document and Word
wrdDoc.Close
'wrdApp.Quit
End If
If objFSO.FileExists(tmpFileName) Then
objFSO.DeleteFile tmpFileName
End If
' maximize outlook now that we have finished
''OutlookObj.ActiveExplorer.WindowState = olMaximized
'objShell.UndoMinimizeALL
Set objShell = Nothing
Set dlgSaveAs = Nothing
'Cleanup
Set MyOlNamespace = Nothing
Set MyOlSelection = Nothing
Set MySelectedItem = Nothing
Set wrdDoc = Nothing
Set wrdApp = Nothing
Set oRegEx = Nothing
End If
'ErrorHandling:
' MsgBox "The Email failed to save, please delete the Evaluation record and try again or manually save the email as a PDF and add it.", vbOKOnly, "Error Saving Email"
' EVAL_SaveAsPDFfile = ""
End Function