Save attachments in order
I am trying to run a macro through a rule in Outlook that saves attachments to a folder.
Emails sometimes contain more than one attachment. I am trying to keep the files in order, so, for example, if I go to email, I can easily see the file that matches it.
I have the following that I found on the internet:
Public Sub saveAttachtoDisk(itm As Outlook.MailItem)
Dim objAtt As Outlook.Attachment
Dim saveFolder As String
saveFolder = "C:\PathToDirectory\"
Dim dateFormat As String
dateFormat = Format(itm.ReceivedTime, "yyyy-mm-dd Hmm ")
For Each objAtt In itm.Attachments
objAtt.SaveAsFile saveFolder & "\" & dateFormat & objAtt.DisplayName
Next
End Sub
I tried to play with with objatt.displayname
no luck. I tried to assign new names and create a new loop that names the files File 1, File 2, etc., but when I do that, I lose the file extension.
Updated version:
Option Explicit
Public Sub save_attachments(itm As Outlook.MailItem)
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Dim strExt As String
Dim i As Long
Dim savefolder As String
i = 1
savefolder = "C:\Users\w\desktop\test"
For Each objAtt In itm.Attachments
i = i + 1
strExt = fso.GetExtensionName(objAtt.DisplayName)
objAtt.SaveAsFile savefolder & "\" & dateFormat & " - File " & i & "." & strExt
Next
End Sub
source to share
You can do something like this in your existing subroutine. This will increase the number "File"
and keep the expansion.
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Dim strExt As String
Dim i As Long
For Each objAtt In itm.Attachments
i = i + 1
strExt = fso.GetExtensionName(objAtt.DisplayName)
objAtt.SaveAsFile saveFolder & "\" & dateFormat & " - File " & i & "." & strExt
Next
source to share
I have been using a similar solution for a while now. I recently added this coding world to avoid storing inline images:
Extension = LCase$(Right$(FileNm, 3))
If Extension = "png" Or Extension = "gif" Or Extension = "jpg" Then
*** Save File ***
Endif
Assuming you don't get the image files you want to keep.
If you put this before the For Next loop, you can select multiple emails:
For Each Item In Application.ActiveExplorer.Selection
Of course, you will also need to add i = i + 1 elsewhere.
You can also link to your file via email:
FileNameb = Replace(filename, " ", "%20")
Link = "<a href=" + FileNameb + ">" + filename + "</a><br />"
Item.HTMLBody = Item.HTMLBody + Link
And this removes attachments from mail and saves them:
For i = 1 To Item.Attachments.Count
Item.Attachments.Remove 1: 'Remove all attachments
Next i
Item.UnRead = False: 'Mark e mail as read
Item.Save
Good luck!
source to share