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  amp       amp  dateFormat  amp  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

User · Answer

I actually had solved this not long after posting but failed to post my solution. I honestly don't remember it. But, I had to re-visit the task when I was given a new project that faced the same challenge.

I used the ReceivedTime property of Outlook.MailItem to get the time-stamp, I was able to use this as a unique identifier for each file so they do not override one another.

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

Thanks a ton for the other solutions, many of them go above an beyond :)

User · Answer

Your question has 2 tasks to be performed  First to extract the Email attachments to a folder and saving or renaming it with a specific name  If your search can be split to 2 searches you will get more hits  I could refer one page that explains how to save the attachment to a system folder  lt Link for the page to save attachments to a folder gt   Please post any page or code if you have found to save the attachment with specific name

User · Answer

Public Sub Extract Outlook Email Attachments    Dim OutlookOpened As Boolean Dim outApp As Outlook Application Dim outNs As Outlook Namespace Dim outFolder As Outlook MAPIFolder Dim outAttachment As Outlook Attachment Dim outItem As Object Dim saveFolder As String Dim outMailItem As Outlook MailItem Dim inputDate As String  subjectFilter As String   saveFolder    Y  Wingman    THIS IS WHERE YOU WANT TO SAVE THE ATTACHMENT TO  If Right saveFolder  1   lt  gt      Then saveFolder   saveFolder  amp       subjectFilter     Daily Operations Custom All Req Statuses Report     THIS IS WHERE YOU PLACE THE EMAIL SUBJECT FOR THE CODE TO FIND  OutlookOpened   False On Error Resume Next Set outApp   GetObject    Outlook Application   If Err Number  lt  gt  0 Then     Set outApp   New Outlook Application     OutlookOpened   True End If On Error GoTo 0  If outApp Is Nothing Then     MsgBox  Cannot start Outlook    vbExclamation     Exit Sub End If  Set outNs   outApp GetNamespace  MAPI   Set outFolder   outNs GetDefaultFolder olFolderInbox   If Not outFolder Is Nothing Then     For Each outItem In outFolder Items         If outItem Class   Outlook OlObjectClass olMail Then             Set outMailItem   outItem                 If InStr 1  outMailItem Subject  subjectFilter   gt  0 Then  removed the quotes around subjectFilter                     For Each outAttachment In outMailItem Attachments                     outAttachment SaveAsFile saveFolder  amp  outAttachment filename                      Set outAttachment   Nothing                      Next                 End If         End If     Next End If  If OutlookOpened Then outApp Quit  Set outApp   Nothing  End Sub

User · Answer

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  amp    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  gt  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  amp  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  lt  gt  olFormatHTML Then                 strDeletedFiles   strDeletedFiles  amp  vbCrLf  amp    lt file      amp  strFile  amp    gt               Else                 strDeletedFiles   strDeletedFiles  amp    lt br gt    amp    lt a href  file      amp                    strFile  amp     gt    amp  strFile  amp    lt  a gt               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  lt  gt  olFormatHTML Then             objMsg Body   vbCrLf  amp   The file s  were saved to    amp  strDeletedFiles  amp  vbCrLf  amp  objMsg Body         Else             objMsg HTMLBody     lt p gt    amp   The file s  were saved to    amp  strDeletedFiles  amp    lt  p gt    amp  objMsg HTMLBody         End If         objMsg Save     End If Next  ExitSub   Set objAttachments   Nothing Set objMsg   Nothing Set objSelection   Nothing Set objOL   Nothing End Sub

User · Answer

See ReceivedTime Property  http   msdn microsoft com en-us library office aa171873 v office 11  aspx  You added another   to the end of C  Temp  in the SaveAs File line  Could be a problem  Do a test first before adding a path separator   dateFormat   Format itm ReceivedTime   yyyy-mm-dd H-mm     saveFolder    C  Temp    You have not set objAtt so there is no need for  Set objAtt   Nothing   If there was it would be just before End Sub not in the loop     Public Sub saveAttachtoDisk  itm As Outlook MailItem       Dim objAtt As Outlook Attachment      Dim saveFolder As String Dim dateFormat     dateFormat   Format itm ReceivedTime   yyyy-mm-dd H-mm    saveFolder    C  Temp      For Each objAtt In itm Attachments         objAtt SaveAsFile saveFolder  amp       amp  dateFormat  amp  objAtt DisplayName     Next End Sub   Re  It worked the first day I started tinkering but after that it stopped saving files      This is usually due to Security settings  It is a  trap  set for first time users to allow macros then take it away   http   www slipstick com outlook-developer how-to-use-outlooks-vba-editor

User · Answer

Added simple code to save with readable date-time stamp   Use sync2pst to sync all your data in outlook with all your devices  work like this    you only need to buy 1 license  save your pst file on one computer  let s call this pc  server   on your network  create scheduled tasks that will synchronize the pst file on your  server  with all the pst files on all your devices  no matter which device downloaded the emails first  you need some dos programming knowledge to bypass pst files that are open at sync time   save all your attachments on the same skydrive folder that is located on the same place on all your devices  e g  e  skydrive attachments  Use the code below on all your devices to save attachments  change the path as mentioned above  Use ONLY ONE PST-file for all your accounts  make folders  subfolders and so     in VBA  refer to  microsoft scripting runtime extra references     here s the code     Private Sub Application NewMail   SaveAttachments End Sub  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 Dim fs As FileSystemObject    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    F  SkyDrive 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  gt  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          Set fs   New FileSystemObject          For i   lngCount To 1 Step -1                Save attachment before deleting from item                Get the file name              strFile   Left objAttachments Item i  FileName  Len objAttachments Item i  FileName  - 4          Right  00    Trim Str  Day Now     2          Right  00    Trim Str  Month Now     2          Right  0000    Trim Str  Year Now     4          Right  00    Trim Str  Hour Now     2          Right  00    Trim Str  Minute Now     2          Right  00    Trim Str  Second Now     2    Right  objAttachments Item i  FileName   4                 Combine with the path to the Temp folder              strFile   strFolderpath  amp  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  lt  gt  olFormatHTML Then                 strDeletedFiles   strDeletedFiles  amp  vbCrLf  amp    lt file      amp  strFile  amp    gt               Else                 strDeletedFiles   strDeletedFiles  amp    lt br gt    amp    lt a href  file      amp                    strFile  amp     gt    amp  strFile  amp    lt  a gt               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  lt  gt  olFormatHTML Then             objMsg Body   vbCrLf  amp   The file s  were saved to    amp  strDeletedFiles  amp  vbCrLf  amp  objMsg Body         Else             objMsg HTMLBody     lt p gt    amp   The file s  were saved to    amp  strDeletedFiles  amp    lt  p gt    amp  objMsg HTMLBody         End If          objMsg Save     End If Next  ExitSub   Set objAttachments   Nothing Set objMsg   Nothing Set objSelection   Nothing Set objOL   Nothing End Sub

[vba] Save attachments to a folder and rename them

Examples related to vba

Examples related to outlook

Examples related to attachment