PDA

View Full Version : [SOLVED:] Have Save Dialog Box Appear with a preset folder and file type


rm7885
01-14-2015, 10:35 AM
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


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
gmayor
01-14-2015, 11:52 PM
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.



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
rm7885
01-27-2015, 11:39 AM
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.


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?



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]
gmayor
01-28-2015, 05:18 AM
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.



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