Save attachments to a folder and rename them

Question

I'm trying to get a VBA macro in Outlook that will save an email's attachment to a specific folder and add the date received to the file name.

My googling has gotten me this far:

Public Sub saveAttachtoDisk (itm As Outlook.MailItem)      Dim objAtt As Outlook.Attachment      Dim saveFolder As String     Dim dateFormat As String     saveFolder = "C:\Temp\"     dateFormat = Format(Now, "yyyy-mm-dd H-mm")      For Each objAtt In itm.Attachments         objAtt.SaveAsFile saveFolder & "\" & dateFormat & objAtt.DisplayName         Set objAtt = Nothing     Next  End Sub 

The first obvious thing is that it's applying the current time to the file name instead of the received time, but I can't seem to change it. My theory is that the Outlook.Attachment doesn't have a ReceivedTime and that the email itself has to be referenced.

Secondly, this doesn't seem to work at all, ha! It worked the first day I started tinkering but after that it stopped saving files.

Answer 1

This is my Save Attachments script. You select all the messages that you want the attachments saved from, and it will save a copy there. It also adds text to the message body indicating where the attachment is saved. You could easily change the folder name to include the date, but you would need to make sure the folder existed before starting to save files.

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 lngCount As Long Dim strFile As String Dim strFolderpath As String Dim strDeletedFiles 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 = strFolderpath & "\Attachments\"  ' 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          ' 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              ' 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              ' 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          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 & "The file(s) were saved to " & strDeletedFiles & vbCrLf & objMsg.Body         Else             objMsg.HTMLBody = "<p>" & "The file(s) were saved to " & 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