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]
Reply With Quote
