Last reviewed on July 13, 2015   —  117 Comments

The following code works in Outlook 2000 and up. It saves the attachments from selected messages but does not delete the attachments from the message(s). This VBA code is based on the code sample at our Outlook-Tips site: Save and Delete Attachments. Use it if you want to save the attachment, add a link to the saved file, and delete the attachment from the message.

Instructions to add the macro to a toolbar button or ribbon command are at the end of the page.

Save Attachments to the hard drive

Copy and paste the code from this page into your ThisOutlookSession project.

In Outlook, press Alt+F11 to open the VBA editor and expand Microsoft Outlook Objects then double click on ThisOutlookSession to open it in the editing pane and Ctrl+V to paste the code.

To use it you must first create a folder under your My Documents named OLAttachments (the code will not create it for you). Then select one or more messages and run the macro to save the attachments. You'll need to set macro security to warn before enabling macros or sign the macro. You can change the folder name or path where the attachments are saved by editing the code.

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

' The attachment folder needs to exist
' You can change this to another folder name of your choice

    ' Set the Attachment folder.
    strFolderpath = strFolderpath & "\OLAttachments\"

    ' Check each selected item for attachments. 
    For Each objMsg In objSelection

    Set objAttachments = objMsg.Attachments
    lngCount = objAttachments.Count
        
    If lngCount > 0 Then
    
    ' 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
    
    ' 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
    
    Next i
    End If
    
    Next
    
ExitSub:

Set objAttachments = Nothing
Set objMsg = Nothing
Set objSelection = Nothing
Set objOL = Nothing
End Sub

Use an ItemAdd to Save Attachments on Arrival

This macro runs (automatically) on messages as they are added to the Inbox. Put it in ThisOutlookSession.

Option Explicit

Private WithEvents olInboxItems As Items
 
Private Sub Application_Startup()
  Dim objNS As NameSpace
  Set objNS = Application.Session
  ' instantiate objects declared WithEvents
  Set olInboxItems = objNS.GetDefaultFolder(olFolderInbox).Items
  Set objNS = Nothing
End Sub
 
Private Sub olInboxItems_ItemAdd(ByVal Item As Object)
  On Error Resume Next
If Item.Attachments.Count > 0 Then
 
Dim objAttachments As Outlook.Attachments
Dim lngCount As Long
Dim strFile As String
Dim sFileType As String
Dim i as long

Set objAttachments = Item.Attachments
    lngCount = objAttachments.Count
 For i = lngCount To 1 Step -1

' 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

 Next i
End If

End Sub

Add the message date to the filename

If you want to add the message date to the file, you'll need to get the date from the SentOn or ReceivedDate fields then format it as a string before adding it to the file name. It's a total of 4 new lines and one edited line.

First, Dim the two new variables at the top of the macro:

Dim dtDate As Date
Dim sName As String

To format the date and time and add it to the filename in 20130905045911-filename format, you'll add two lines of code after you count the attachments to get the date and format it, then edit the line that creates the filename.


    If lngCount > 0 Then

       dtDate = objMsg.SentOn

         sName = Format(dtDate, "yyyymmdd", vbUseSystemDayOfWeek, vbUseSystem) & Format(dtDate, "hhnnss", vbUseSystemDayOfWeek, vbUseSystem) & "-"

   For i = lngCount To 1 Step -1

    ' Get the file name.
       strFile = sName & objAttachments.Item(i).FileName

Don't save images in signatures

This macro saves all attachments, including images embedded in signatures (they are attachments after all). To avoid saving signature images, you have two options: don't save image files, or don't save smaller files. You could even do both and save only larger images files.

Replace the code between For i = lngCount To 1 Step -1 / Next i lines with the following to filter out files smaller than 5KB. This should catch most signature images (and many text files).

If the attachments you need to save are always over 5 KB, you can increase the file size. (For reference, a blank Word document is over 10KB.)

    For i = lngCount To 1 Step -1
       If objAttachments.Item(i).Size > 5200 Then

    ' 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
     End If
     
    Next i

Save by File type

If you want to skip or save only a specific file type, use If LCase(Right(strFile, 4)) <> ".ext" format, where .ext is the extension. Add it after the first line strFile = line (and don't forget to add the End if before the Next i). You can use it to exclude a file type or use an equal (=) sign to save only a specific file type. (For 4-character extensions, use only the characters, don't include the dot.)

To work with a longer list of file types, use a Select Case statement. In this example, we're looking for image attachments, and if less than approx 5KB, we skip them. Larger image attachments will be saved.

    For i = lngCount To 1 Step -1
     
    ' Get the file name.
    strFile = objAttachments.Item(i).filename
     
' This code looks at the last 4 characters in a filename
      sFileType = LCase$(Right$(strFile, 4))
 
      Select Case sFileType
 ' Add additional file types below
       Case ".jpg", ".png", ".gif"
        If objAttachments.Item(i).Size < 5200 Then
     GoTo nexti
        End If
      End Select

     
    ' Combine with the path to the Temp folder.
    strFile = strFolderpath & strFile
     
    ' Save the attachment as a file.
    objAttachments.Item(i).SaveAsFile strFile
    
nexti:
    Next i

 

Add a number to each attachment

This macro merges the first macro on this page with the macro at Write the last used value to the registry sample to add a number to each saved attachment, incrementing as attachments are saved. Because the last used value is in the registry, the count will persist because restarts.

Get the complete macro, ready to use: AttachmentIndex

 ' HKCU\Software\VB and VBA Program Settings\Outlook\Index
    sAppName = "Outlook"
    sSection = "Index"
    sKey = "Last Index Number"
 ' The default starting number.
     iDefault = 101 ' adjust as needed
  
 ' Get stored registry value, if any.
     lRegValue = GetSetting(sAppName, sSection, sKey, iDefault)
  
 ' If the result is 0, set to default value.
     If lRegValue = 0 Then lRegValue = iDefault
 
' Put the save attachment code here 
    strFolderpath = CreateObject("WScript.Shell").SpecialFolders(16)
    On Error Resume Next
 
    Set objOL = Application
    Set objSelection = objOL.ActiveExplorer.Selection
    strFolderpath = strFolderpath & "\OLAttachments\"
 
    For Each objMsg In objSelection
    Set objAttachments = objMsg.Attachments
    lngCount = objAttachments.Count
         
    If lngCount > 0 Then
    For i = lngCount To 1 Step -1
    
 ' Get the file name.
    strFile = objAttachments.Item(i).fileName
    
    lcount = InStrRev(strFile, ".") - 1
    pre = Left(strFile, lcount)
    ext = Right(strFile, Len(strFile) - lcount)
 
    ' Combine with the path to make the final path
    strFile = strFolderpath & pre & "_" & lRegValue & ext
  
    strFile = strFolderpath & strFile
    objAttachments.Item(i).SaveAsFile strFile

' add 1 to the index  
    lRegValue = lRegValue + 1
        Err.Clear
    Next
    
   ' update the registry at the end
     SaveSetting sAppName, sSection, sKey, lRegValue

Save Attachments in Subfolders

To save the attachments in subfolders, you need to use the File Scripting Object to create the folder if it does not exist.

A complete, ready-to-use sample macro is here.

For Each objMsg In objSelection
 
  ' Set the Attachment folder.
    strFolder = strFolderpath & "\OLAttachments\"  
    Set objAttachments = objMsg.Attachments
' put it together with the sender name  
 strFolder = strFolder & objMsg.SenderName & "\"
    
 ' if the sender's folder doesn't exist, create it
 If Not FSO.FolderExists(strFolder) Then
 FSO.CreateFolder (strFolder)
 End If
 
    lngCount = objAttachments.Count        
    If lngCount > 0 Then
      For i = lngCount To 1 Step -1
    strFile = objAttachments.Item(i).FileName
    strFile = strFolder & strFile
    objAttachments.Item(i).SaveAsFile strFile
        

Assign the macro to a button

In Outlook 2007 and older, you can create a toolbar button to run the macro. In Outlook 2010, you'll need to customize the ribbon.

More information is at Customize the Outlook Toolbar, Ribbon or QAT and at Customizing the Quick Access Toolbar (QAT).

Run the macro using a ribbon or QAT shortcut

Step 1: To create a button to run a macro in Outlook 2010, go to File, Options, and choose Customize Ribbon. (If you want a button on the QAT, choose Quick Access Toolbar instead.)
customize the ribbon to add a macro button
Step 2: Choose Macro from the Choose Commands From menu and select the macro you want to add to the ribbon or QAT.

Step 3: Select the Group you want to add the macro to. If it doesn't exist yet, use the New Group buttons to create the group.

Step 4: Use the Rename button to give the macro a friendly name and change the icon. You are limited to the icons in the dialog (unless you want to program a ribbon command).

Run the macro from a toolbar button

To create a toolbar button for it, go to View, Toolbar, Customize, Commands tab. In the Categories pane, type M to jump to Macros. On the Commands side, drag the macro you created to the toolbar. Right click on the button to rename it and assign a new icon.

customize toolbar dialog


Comments

    • Diane Poremsky says

      Each nested message as separate messages rather than one attachment? No, not easily. You can drag the message attachment to a folder then run the macro.

  1. donna russo says

    Hi Diane,

    Do you know if there is a script to:
    1. open email (jotform)
    2. click on link in body of email--field on the jotform (which has the attachment)
    3.Save the attachment that opened when link is clicked to a folder?

    Thanks,
    Donna

    • Diane Poremsky says

      Automatically? If the enclosures are downloaded, yes. For automatic use, you'd need to watch the folder (easiest with 1 folder or if all are delivered to 1 folder).

  2. nik says

    no, just execute the macro for all unread RSS (or selected).

    > If the enclosures are downloaded
    OK. There would be no macro option (at least a manual method in Outlook settings), which automatically downloads the attachments of all RSS items?

    • Diane Poremsky says

      To the best of my knowledge, no, that is not exposed in the object model. You could use send keys to get it, but that is really messy.

  3. Andy McCarthy says

    Hello Diane,

    Is it possible to modify the code so that the "save attachment" window launches during each loop? Certainly not as fast but it would give me the ability to process multiple emails and save files to various locations.

    Thanks!

    Andy

    • Diane Poremsky says

      yes, it is. I have code here somewhere for a folder picker. I'll see if i can find it.

  4. Diane Poremsky says

    Use this as the folder path -
    strFolderpath = BrowseForFolder("\\")

    this as the path and file name
    strFile = strFolderpath & "\" & strFile

    and this function:

    Function BrowseForFolder(Optional OpenAt As Variant) As Variant
    'Function To Browse for a user selected folder.
    'If the "OpenAt" path is provided, open the browser at that directory
    'NOTE: If invalid, it will open at the Desktop level
    Dim ShellApp As Object
    'Create a file browser window at the default folder
    Set ShellApp = CreateObject("Shell.Application"). _
    BrowseForFolder(0, "Please choose a folder", 0, OpenAt)
    'Set the folder to that selected. (On error in case cancelled)
    On Error Resume Next
    BrowseForFolder = ShellApp.self.Path
    On Error GoTo 0
    'Destroy the Shell Application
    Set ShellApp = Nothing
    'Check for invalid or non-entries and send to the Invalid error
    'handler if found
    'Valid selections can begin L: (where L is a letter) or
    '\\ (as in \\servername\sharename. All others are invalid
    Select Case Mid(BrowseForFolder, 2, 1)
    Case Is = ":"
    If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
    Case Is = "\"
    If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
    Case Else
    GoTo Invalid
    End Select
    Exit Function
    Invalid:
    'If it was determined that the selection was invalid, set to False
    BrowseForFolder = False
    End Function

    • Diane Poremsky says

      So it skips button multiple attachments on one message and attachments on multiple messages?

      I'd add either debug.print objMsg.subject & objAttachments.Count or msgbox objMsg.subject & objAttachments.Count after
      lngCount = objAttachments.Count line to see if it's rolling through the other messages or just ending.

      If you use msgbox, only select a few messages - otherwise it is annoying. Debug.print will show in the Immediate window - you can show it from the View menu in the VBE.

  5. Osbaldo Martinez Garcia says

    Hi Diana, thank you very much for the macro, which is the only way to download xml files? is it possible?

    Thanks and Regards

    • Diane Poremsky says

      It doesn't work with xml attachments? It *should* work with all attachments. I know XML may be handled differently in OWA but it should work in Outlook.

  6. Kevin Thomas says

    Hi, Diane,
    Thank you so much for this. I tried changing strFolderpath and the script fails without any sign of an error - the file just doesn't get where I set it. Any guidelines about how to refer to file locations? I'm a complete noob to VBA. Thanks in advance for any help you can give.

    -Kevin

    • Diane Poremsky says

      Step into each line using Debug > Step into or F8. Is it skipping any lines?

      While you are stepping into the code, you can hover the mouse over the strFolderpath line (after you move to the next line) and see the path the macro wants to use - but basically, it uses your My Documents and you need to use \ to identify the folders, strFolderpath does not include it. If you leave a slash off, it's added to the previous folder name or prefix to the filename. The subfolder also needs to exist.

      If you use strFolderpath = strFolderpath & "\OLAttachments", the attachment is saved as C:\Users\Diane\Documents\OLAttachmentsfilename.extension

      and strFolderpath = strFolderpath & "OLAttachments\" looks for C:\Users\Diane\DocumentsOLAttachments\filename.doc

  7. jzelnock says

    Diane,
    Is there a way to add the Outlook 'SentOn' date to the saved filename so I can easily match it to the email it was attached to?
    J Zelnock

    • Diane Poremsky says

      Yes, you just need to format the value in the field and add it to the file name.

      At the top:
      Dim dtDate As Date
      Dim sName As String

      Replace the for i =... and first strFile lines with this:

      dtDate = objMsg.SentOn
      ' format date/time as 20130905045911-
      sName = Format(dtDate, "yyyymmdd", vbUseSystemDayOfWeek, _
      vbUseSystem) & Format(dtDate, "hhnnss", _
      vbUseSystemDayOfWeek, vbUseSystem) & "-"

      For i = lngCount To 1 Step -1

      ' Get the file name.
      strFile = sName & objAttachments.Item(i).FileName

  8. jzelnock says

    Diane,
    One more question. Occasionally I'm finding that certain senders used embedded images in their signatures. The macro reads these images as attachments. Is there any way to prevent that from happening?
    Janice Zelnock

    • Diane Poremsky says

      That is the one big limitation... you can't prevent it completely, but if you don't need to save images you can add an if statement. Or you can save only files larger than a certain size, say 5 kb. That size will still catch a few signature images, but if file you want to save are well over that, you can go higher.

      Try adding something like this after you count the attachments.
      For Each objAttachments In objMsg.Attachments
      If objAttachments.Item(i).Size > 5200 Then
      ' do the save stuff

      End If
      Next objAttachments

      I'll test it and update the page with the code.

    • Diane Poremsky says

      That was a little overkill - you only need the if statement for the file size (and the end if)

      For i = lngCount To 1 Step -1
      If objAttachments.Item(i).Size > 5200 Then
      ' create filename, save it

      End If
      Next i

  9. Lydia says

    I'm looking for a way to save the attachment as the email address of the sender (that way I can easily identify in the folder who sent which attachment). How would I define that in the code?

    • Diane Poremsky says

      use something like strFile = objMsg.senderemailaddress & "-" & objAttachments.Item(i).FileName

    • Diane Poremsky says

      I don't know if there is a way to pass the logon if you don't map the drive, but this should work
      persistent = false
      set objNetwork = WScript.CreateObject("WScript.Network")
      objNetwork.MapNetworkDrive "driveletter:", "\\server\folder", persistent, "username", "password"

  10. englishgent says

    Hi Diane,

    Thank you for taking the time to write these tips and answer people's questions.

    What I'd find really useful is for the macro to insert the filepath and filename of the saved attachments into the top of the email body. That way, I could quickly determine whether an email had any attachments, and go and find it/them in the folder in which they are saved.

    I think what I'm asking for is to add the 'strFile' value to the start of the email body. If this could be done as a hyperlink, it would be fantastic, although just plain text would be much better than nothing. Do you know of a way to do this?

    Many thanks for your help.

    • Diane Poremsky says

      The original code from outlook-tips added it at the end - to add it to the top, switch the order in the objMsg.Body = lines.
      If objMsg.BodyFormat <> olFormatHTML Then
      strDeletedFiles = strDeletedFiles & vbCrLf & ""
      Else
      strDeletedFiles = strDeletedFiles & "
      " & "" & strFile & ""
      End If

      Next i
      'End If

      ' Adds the filename string to the message body and save it
      ' Check for HTML body
      If objMsg.BodyFormat <> olFormatHTML Then
      objMsg.Body = objMsg.Body & vbCrLf & _
      "The file(s) were saved to " & strDeletedFiles
      Else
      objMsg.HTMLBody = objMsg.HTMLBody & "

      " & _
      "The file(s) were saved to " & strDeletedFiles & "

      "
      End If
      objMsg.Save

  11. neilv says

    I used to use this code a while back but running it with the msg box just now I can see there is an issue with the path for

    ' Get the path to your My Documents folder
    strFolderpath = CreateObject("WScript.Shell").SpecialFolders(16)
    On Error Resume Next

    and..

    ' Set the Attachment folder.
    strFolderpath = strFolderpath & "J:\Mail Backups\OLAttachments"

    It appears to be referencing a backup sync folder on our network rather then my documents locally.

    thus the attachement folder ends up

    servername/home/profilenameJ:\Mail Backups\OLAttachments

    is there anything i can do about this?

    • Diane Poremsky says

      This is wrong - strFolderpath = strFolderpath & "J:\Mail Backups\OLAttachments"

      if you want it in the backups folder, use
      use strFolderpath = "J:\Mail Backups\OLAttachments\"

      or strFolderpath = strFolderpath & "\OLAttachments\" if you want it a subfolder in the temp folder.

  12. Neilv says

    Perfect, Many thanks Diane, I wonder where the correct piece of code i was using a few months ago went lol. Thank you again

  13. ZimN27 says

    Hi Diana! Thank you so much for providing these code and some of your knowledge.
    This macro works flawlessly with the exception of not keeping the files with the same name.

    I have over 1000 email to work with an attachment in excel and all have the same name.

    Can you help me?

    Thank you very much.

  14. ZimN27 says

    Very grateful! I had never worked with VBA before. I'm a layman.
    You've no idea how it helped me!
    Diane is the best!
    Obrigado (Portugal)

  15. Andy McCarthy says

    Hello Diane!

    My script creates a new folder on a mapped network drive in which to save the attachments, but I encounter an error when I actually try to have the script save the attachments (I receive an error message that I don't have permission). It seems odd that I can create a folder via VBA but the same macro can't then save to that newly created folder. I don't have this error if I create then save to a folder on my local hard drive, only when trying to save to a mapped drive. As always, I'd be very grateful if you could point me in the right direction! Thanks, Andy

  16. Andy McCarthy says

    Hi Diane - I'm sorry: I didn't realize you had later posted the code. Thanks very much. I'm going to try it. Andy

  17. Andy McCarthy says

    Hello again - please disregard. I figured out the issue. The error was in my code. I wasn't putting together the strings correctly and had also left out .DisplayName which means there was no filename to save. Duh. Thanks!

    • Diane Poremsky says

      Thanks for the update. I'm sure you aren't the only one who makes silly mistakes like that. :)

  18. henri says

    BrowseForFolder is close to what I want, but I can't navigate anywhere with it is the another shell application I could use instead?

  19. henri says

    I should elaborate. I get the browseforfolder dialog, but the ability to browse is there. No crosses next to folders, no tree structure down the left. What do I need to do to get it working correctly. I've seen mention of IE4 and 5, I've got 11. But I don't see why the later version would matter. The pics I've seen seem to indicate later versions should be O.K.

    • Diane Poremsky says

      I don't think the browser version is the problem. If you click on folders do they expand?

  20. Kevin B says

    First off, thanks for all the vba help! I have referenced your material quite often.

    How would you modify the above code to save the email attachments to a created folder using the subject as the folder name?

    Thanks in advance!

    • Diane Poremsky says

      so you want to save a message with the subject "Howdy Kevin" to a folder at \My Documents\Howdy Kevin\document.docx - try something like this:
      strFile = strFolderpath & "\" & objMsg.subject & & "\" strFile

      You'll probably need the file scripting object to create the folder

  21. Santi says

    Hi Diane,

    Do you know how to create script in outlook that will automatically unzip an attachment when an email arrives and save it to local folder ?

    I have to extract the attachment & save the file from distributor every day. But because I have to do it manually, sometime I forgot or missed to do it.

    Can you please help me ?

    warmth regard,
    Santi

    • Diane Poremsky says

      it would depend on the application you use to unzip - if it can be controlled by command line, you could probably do it from a macro.

  22. thomas d says

    Hello Dian,
    Is there anyway to have it so that each attachment is name after the subject line of the email it came from? And if there is more than one attachment, it will just be saved as "example" and "example (1)".
    Thanks!

    • Diane Poremsky says

      you can add the name but it won't add (1) to the names - you'll need to use code that adds a number. I'd probably recommend using subject-attachmentname format to avoid problems.

  23. John says

    Hello Diane
    Looking for a VBA by which I could extract / save all the PDF attachments from a particular mail. However these mails have further email attachments in them inside which lies these PDF files.
    So basically it has to fetch all the attachments from the sub-msg files when the parent email is selected.

    Is there a way to do this?

  24. RD says

    Diane,

    I setup this script in Outlook 2013 and modified the folder location but when the rule runs nothing is being placed in the folder. It doesn't error out and the progress bar runs across as if the script is successful but no go. Can you tell me what I modified wrong please?

    Public Sub saveAttachtoDisk(itm As Outlook.MailItem)
    Dim objAtt As Outlook.Attachment
    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 objAtt = CreateObject("Outlook.Application")

    ' Get the collection of selected objects.
    Set objSelection = objAtt.ActiveExplorer.Selection

    ' The attachment folder needs to exist
    ' You can change this to another folder name of your choice

    ' Set the Attachment folder.
    strFolderpath = "C:\AutoAttach"

    ' Check each selected item for attachments.
    For Each objMsg In objSelection

    Set objAttachments = objMsg.Attachments
    lngCount = objAttachments.Count

    If lngCount > 0 Then

    ' 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

    ' 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

    Next i
    End If

    Next

    End Sub

    • Diane Poremsky says

      This one, with (itm as outlook.mailitem) in the macro name, should run in a rule. Itemadd in the macro name would run as items are added to the folder.

    • Diane Poremsky says

      if it's running as a rule, you don't need to set the outlook.application or use the selection and the message object is 'itm'.

      Try this:
      Public Sub saveAttachtoDisk(itm As Outlook.MailItem)
      Dim objAttachments As Outlook.Attachments
      Dim i As Long
      Dim lngCount As Long
      Dim strFile As String
      Dim strFolderpath As String

      ' Set the Attachment folder.
      strFolderpath = "C:\AutoAttach\"

      Set objAttachments = itm.Attachments
      lngCount = objAttachments.Count

      If lngCount > 0 Then

      For i = lngCount To 1 Step -1
      strFile = objAttachments.Item(i).filename
      strFile = strFolderpath & strFile
      objAttachments.Item(i).SaveAsFile strFile
      Next i
      End If
      End Sub

    • Diane Poremsky says

      Oh, and the file path needs to end with \ - otherwise the attachmnents are saved to C:\ and named autoattachfilename

  25. AyoolaAlam says

    Hi Diane,

    Thank you for taking the time to write these tips and answer people's questions.

    Pls have been trying to create a folder path i.e when the customized ribbon is clicked, it ask the user to browse to the folder path to save the selected mail. Here is my sample code but its not working. Pls can U pls help

    Option Explicit
    Public Sub SaveMessageAsMsg()
    Dim oMail As Outlook.MailItem
    Dim objItem As Object
    Dim sPath As String
    Dim dtDate As String
    Dim sName As String
    Dim enviro As String
    Dim strFile As String
    Dim olMSG As String

    For Each objItem In ActiveExplorer.Selection
    Set oMail = objItem

    sName = oMail.Subject

    dtDate = oMail.SenderName

    sName = Format(dtDate, "yyyymmdd", vbUseSystemDayOfWeek, _
    vbUseSystem) & Format(dtDate, "-hhnnss", _
    vbUseSystemDayOfWeek, vbUseSystem) & "-" & sName & ".msg"

    sPath = BrowseForFolder("T:TempCorrespondence")
    strFile = sPath & "Correspondence" & strFile

    Debug.Print sPath & sName
    oMail.SaveAs sPath & sName, olMSG
    MsgBox ("Message is Successfully Copied")
    Next
    End Sub

    Function BrowseForFolder(Optional OpenAt As Variant) As Variant
    Dim ShellApp As Object
    Set ShellApp = CreateObject("Shell.Application"). _
    BrowseForFolder(0, "Please choose a folder", 0, OpenAt)

    On Error Resume Next
    BrowseForFolder = ShellApp.self.Path
    End Function

    • AyoolaAlam says

      Thanks alot for you response,
      Yes the path exist it was returning an error at "oMail.SaveAs sPath & sName, olMSG" which says "Tye MissMatch". Pls what do you think might be wrong. Thanks alot

    • Diane Poremsky says

      Does the path exist? use debug.print or a msgbox to display the folder path and file name so you can verify it exists.

  26. stushapiro says

    Thank you so much for this. Its a bit over my head but im piecing things together as i dont do programming.

    Can you help modify this simple script i have working.
    The script currently saves out all the files as ".jpg" as .jpeg wont work for my needs.

    *I simply want to add that it only saves ".jpeg" and ".jpg" and ignores all other attachments
    __________________________________________

    Public Sub saveAttachtoDisk(itm As Outlook.MailItem)
    Dim objAtt As Outlook.Attachment
    Dim saveFolder As String
    Dim dateFormat As String
    Dim strFileExtension As String

    saveFolder = "C:\emails\"
    dateFormat = Format(itm.ReceivedTime, "yyyy-mm-dd Hmm ")
    strFileExtension = ".jpg"

    For Each objAtt In itm.Attachments
    objAtt.SaveAsFile saveFolder & "\" & dateFormat & objAtt.DisplayName & strFileExtension
    Set objAtt = Nothing
    Next
    End Sub

    __________________________________________

    • Diane Poremsky says

      See the last macro snippet in the article for an example of a way to check for different extensions. You need to count the attachments and check each one for the file extension.

    • stushapiro says

      Hi Dave,

      thasnk for the reply. I did see that, its just over my head as im not a programmer. i dont know where or how to add that to my current code. I'm learning by taking things i understand and breaking down examples. This one is just a bit over my head.!

    • Diane Poremsky says

      If you only need to look for jpg or jpeg, you can wrap the line that saves the file in an If/End if statement - the end of your code would look like this:

      For Each objAtt In itm.Attachments

      If LCase(Right(objAtt.filename, 3)) = "jpg" or LCase(Right(objAtt.filename, 4)) = "jpeg"
      objAtt.SaveAsFile saveFolder & "\" & dateFormat & objAtt.DisplayName & strFileExtension
      end if
      Set objAtt = Nothing
      Next
      End Sub

      i didn't test your code - does it work ok? I think the set objatt = nothing should be after the next, not before it.

  27. Stu Shapiro says

    Can anyone help fix this code, red line on the strSaveFilename and nothing hapepens when i run it
    .
    Is saves .JPEG and JPG with the date.
    Converts suffix to lower case
    Saves only jpg files to the emails folder

    Public Sub saveAttachtoDisk(itm As Outlook.MailItem)
    Dim objAtt As Outlook.Attachment
    Dim saveFolder As String
    Dim dateFormat As String
    Dim strFileExtension As String
    Dim strSaveFileName as string

    saveFolder = "C:\emails\"
    dateFormat = Format(itm.ReceivedTime, "yyyy-mm-dd Hmm ")
    strFileExtension = ".jpg"

    For Each objAtt In itm.Attachments
    if lcase(right(objAtt.FileName, 4)) = "jpeg" or lcase(right(obtAtt.FileName, 3) = "jpg") then

    strSaveFileName = mid(objAtt.FileName, instr(1, objAtt.FileName, ".", length(objAtt.FileName) - instr(1, obtAtt.FileName)) & strFileExtension
    objAtt.SaveAsFile saveFolder & "\" & dateFormat & strSaveFileName
    Set objAtt = Nothing
    End if
    Next
    End Sub

    • Diane Poremsky says

      typos/spelling errors seems to be the main problem -
      Public Sub saveAttachtoDisk(itm As Outlook.MailItem)
      Dim objAtt As Outlook.Attachment
      Dim saveFolder As String
      Dim dateFormat As String
      Dim strFileExtension As String
      Dim strSaveFileName As String

      saveFolder = "C:\Users\Diane\Documents\"
      dateFormat = Format(itm.ReceivedTime, "yyyy-mm-dd Hmm ")
      strFileExtension = ".jpg"

      For Each objAtt In itm.Attachments
      If LCase(Right(objAtt.FileName, 4)) = "jpeg" Or LCase(Right(objAtt.FileName, 3) = "jpg") Then

      strSaveFileName = Mid(objAtt.FileName, InStr(1, objAtt.FileName, ".", Len(objAtt.FileName) - InStr(1, objAtt.FileName))) & strFileExtension
      objAtt.SaveAsFile saveFolder & "\" & dateFormat & strSaveFileName
      Set objAtt = Nothing
      End If
      Next
      End Sub

    • Diane Poremsky says

      BTW, it doesn't look like strSaveFilename is doing anything except adding the file extension twice.

  28. vicky says

    Hi Diane Poremsky,

    Thank you sharing this wonderful and useful coding.
    It is really helping me..
    However, if you could tell me the coding to change the desired location other than my documents.
    It will be very helpful.
    Hoping to hear from you soon

    • Diane PoremskyDiane Poremsky says

      These two lines set the location on your hard drive:

      This gets the user's documents folder:
      strFolderpath = CreateObject("WScript.Shell").SpecialFolders(16)

      ' Set the Attachment folder.
      strFolderpath = strFolderpath & "\OLAttachments\"

      You can change those paths as needed or hard-code the path instead of using a variable.
      strFolderpath = "\\fileserver\path\Attachments\"

      I have some other windows environments paths here - http://www.slipstick.com/developer/windows-environment-variables-outlook-macros/

  29. Leuzzo says

    Hi Diane,
    Please help me to do update in the code below so as to create a folder in established location (path D:\MailSave\FirstWordSubject), the folder name is with the first word from the subject mail. If it already exists (path D:\MailSave\) must just to copy the message.

    Sub SaveMsg(MyMail As MailItem)
    On Error GoTo err

    Dim strID As String
    Dim olNS As Outlook.NameSpace
    Dim olMail As Outlook.MailItem

    strID = MyMail.EntryID
    Set olNS = Application.GetNamespace("MAPI")
    Set olMail = olNS.GetItemFromID(strID)

    olMail.SaveAs "D:\MailSave\" & olMail.Subject & ".msg", olMSG

    Set olMail = Nothing
    Set olNS = Nothing
    Exit Sub

    err:
    MsgBox err.Description, vbOKOnly + vbInformation, "Eroare"
    End Sub

    • Diane PoremskyDiane Poremsky says

      You need to use the file scripting object to check for the folder and create it if it doesn't exist.
      Dim strfolderpath as string
      Dim FSO As Object

      strfolderpath = "d:\mailsave\ & firstword
      Set FSO = CreateObject("Scripting.FileSystemObject")

      If Not FSO.FolderExists(StrFolderPath) Then
      FSO.CreateFolder (StrFolderPath)
      End If

  30. Richard says

    Hello Diana, I know it is possible to add an attachment to an item which you will send. But is it possible to save an attachment to a mailitem I received? I understand there is not an option to include an attachment to a current received mailitem in Outlook. But I thought there might be a VBA solution? Reason: I receive an email, read the pdf-attachment, change the subject based on some combined info in the pdf-attachment, save the attachment to my disk with the same new subject name. The last thing I wanted to do is attach the newly saved attachment in which I have made some automatic adjustments to the mailitem I received. I am very curious if this is somehow possible.

    Regards,
    Richard

    • Diane PoremskyDiane Poremsky says

      You can. The manual method is to put the message into Edit mode and add the attachment.

      You can do it with a macro - use an inputbox to ask for the file name then save it, remove the original attachment and add the replacement. This macro sample has the updated code in it - it asks for the new name, saves the file, removes the old file, adds the new one.

      ' Get the file name.
      strFile = objAttachments.Item(i).FileName

      strFile = InputBox("Enter Filename and extension", "Save Attachment", strFile)
      ' Combine with the path to the Temp folder.
      strFile = strFolderpath & strFile

      ' Save the attachment as a file.
      objAttachments.Item(i).SaveAsFile strFile
      ' delete the original
      objAttachments.Item(i).Delete

      'replace with the new one
      objMsg.Attachments.Add strFile
      Next i
      objMsg.Save
      End If

      Next

    • Richard says

      Hi Diana,

      I am fairly suprised, but the code works great, Thank you very much!!

      Regards,
      Richard

  31. John says

    Hi Diane,
    I am using a macro to download attachments to a folder. My problem is when I have two identically named files, only the first one recieved is saved. I believe this is because the macro reads the mail folder from newest to oldest message.
    Can you tell me how I can edit the macro to read the folder from oldest to newest? Alternately, can I tell the macro to skip the save when there is already an identically named file in the save folder? I do not want to add the time/date string to the file name as I do not want duplicate files saved to my folder.
    Thanks!

    • Diane PoremskyDiane Poremsky says

      AFAIK, there isn't an easy way to change the read order but you can try changing the sort order.
      You can wrap the save line with an if statement:
      If Not Dir(strFile) <> "" Then
      objAttachments.Item(i).SaveAsFile strFile
      end if

  32. jhobbes says

    Hi Diane

    Thank you so much for you assistance. The macro runs like a charm, I would just like to save the attachment with the subject name in the OLAttachments folder.

    So I have tried setting an object objString and instead of using :

    Set objAttachments = objMsg.Attachments
    lngCount = objAttachments.Count

    I am using
    Dim objSubject As Outlook.Selection
    .
    .
    .
    Set objSubject = objMsg.Subject
    lngCount = objSubject.Count

    If lngCount > 0 Then

    ' 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

    ' Get the file name.
    strFile = objSubject.Item(i).Subject

    ' Combine with the path to the Temp folder.
    strFile = strFolderpath & strFile

    ' Save the attachment as a file.
    objSubject.Item(i).SaveAsFile strFile

    Next i
    End If

    Next

    But this does not work. Your kind assistance will be appreciated.

  33. Sean Jines says

    I receive 4 reports with similar names with the middle text as the variable (Company Name) I would like it to save the latest from each and overwrite the old file. Currently I have rule to put these report emails into a specified folder. I would like to have one macro to this across multiple PST files. I have another set that comes a zip file can I make it extract the files as XLSX?
    Diane's Post were similar, but I know all mine are excel files.

    • Diane PoremskyDiane Poremsky says

      To delete files (if the macro code doesn't already overwrite them) use
      kill strFile 'where strFile is the full path & filename

      I don't have any code samples that walk all folders in multiple pst files. If you want to do that as the messages arrive, you can use a run a rule script or an itemadd macro - but these work best if you aren't moving the messages to a bunch of folders.

  34. Narasimharao Nandula says

    Hi Diane,

    I am little numb in understanding the VBA code properly. What ever i could understand from your various posts, i am using following code.

    But my problem is that this code moves every new item from my inbox of outlook default session instead of the specified group mail inbox. Kindly note i have pasted this code into "Thisoutlooksession" as follows:

    Private Sub Application_NewMail()

    SaveAttachmentstoHarddrive

    End Sub

    Kindly help me.. Thanking you in advance for your passion of replying so many people and helping others in improving their knowledge.

    Look forward for your advise.

    Best Regards,

    Narasimharao

    Sub SaveAttachmentstoHarddrive()
    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 = "D:Tables"
    'On Error Resume Next

    ' Instantiate an Outlook Application object.

    Dim objNS As Outlook.NameSpace
    Set objNS = Application.GetNamespace("MAPI")

    ' Get the collection of selected objects.

    Set Items = objNS.Folders("Resource Planner").Folders("Inbox").Items

    Set objOL = CreateObject("Outlook.Application")
    Set objSelection = objOL.ActiveExplorer.Selection

    ' Set the Attachment folder.
    strFolderPath = strFolderPath & ""

    ' 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

    ' This code looks at the last 4 characters in a filename
    sFileType = LCase$(Right$(strFile, 4))

    Select Case sFileType
    ' Add additional file types below
    Case ".xls", ".xlsx", ".doc", ".docx"
    End Select

    ' 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 & ""
    Else
    strDeletedFiles = strDeletedFiles & "" & "" & strFile & ""
    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 = "" & "The file(s) were saved to " & strDeletedFiles & "" & objMsg.HTMLBody
    End If
    objMsg.Save
    End If
    Next

    ExitSub:

    Set objAttachments = Nothing
    Set objMsg = Nothing
    Set objSelection = Nothing
    Set objOL = Nothing
    End Sub

    • Diane PoremskyDiane Poremsky says

      These lines tell it to apply to the selected messages
      Set objSelection = objOL.ActiveExplorer.Selection
      For Each objMsg In objSelection

      I assume you want it to work on the items in this folder -
      Set Items = objNS.Folders("Resource Planner").Folders("Inbox").Items - automatically, regardless of what you have selected?

    • Diane PoremskyDiane Poremsky says

      Ok - you need to check the items in the folder -
      For Each objMsg In items

      I didn't test this but i think it will work:
      Sub SaveAttachmentstoHarddrive()
      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 = "D:\Tables"
      'On Error Resume Next

      ' Instantiate an Outlook Application object.

      Dim objNS As Outlook.NameSpace
      Set objNS = Application.GetNamespace("MAPI")
      ' Get the collection of selected objects.
      Set Items = objNS.Folders("Resource Planner").Folders("Inbox").Items

      ' Set the Attachment folder.
      strFolderPath = strFolderPath & "\"

      ' 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 items

      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

      ' This code looks at the last 4 characters in a filename
      sFileType = LCase$(Right$(strFile, 4))

      Select Case sFileType
      ' Add additional file types below
      Case ".xls", ".xlsx", ".doc", ".docx"
      End Select

      ' 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 & ""
      Else
      strDeletedFiles = strDeletedFiles & "" & "" & strFile & ""
      End If

      'Use the MsgBox command to troubleshoot. Remove it from the final code.
      'MsgBox strDeletedFiles

      Next

      ' 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 = "" & "The file(s) were saved to " & strDeletedFiles & "" & objMsg.HTMLBody
      End If
      objMsg.Save
      End If
      Next

      ExitSub:

      Set objAttachments = Nothing
      Set objMsg = Nothing
      Set objSelection = Nothing
      Set objOL = Nothing
      End Sub

  35. Narasimharao Nandula says

    Hi Diane,

    Thank you for prompt response. Yes your understanding is correct. I want to move items with in that specified folder regardless of my selection.
    However I am getting an error that “Object already in use”, could you please confirm where exactly I should add this line?
    Thank you in advance for your response once again. Look forward for your valuable suggestions.

    Best Regards,
    Narasimharao

  36. James says

    Hello Diane,

    I found your original script to be incredibly helpful. I would like to take your code and have it automatically save only attachments from new emails when added to a specific mail folder or simply save attachments for new, unread messages within a specific folder instead of making me select individual messages. This extra automation would make this task perfect for me.

    I have changed the code around a bit and got it to work, but now the script reads all items in the folder and the process takes over 10 minutes to complete and will only continue to grow as I receive more emails.

    Here is my code:

    Public Sub SaveAttachmentsTake2(Item As Outlook.MailItem)
    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 dtDate As Date
    Dim sName As String
    Dim Ns As Outlook.NameSpace

    ' 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 Ns = Application.GetNamespace("MAPI")
    Set Items = Session.GetDefaultFolder(olFolderInbox).Folders("New Data").Items

    ' The attachment folder needs to exist
    ' You can change this to another folder name of your choice

    ' Set the Attachment folder.
    strFolderpath = strFolderpath & "\OLAttachments\"

    ' Check each selected item for attachments

    For Each Item In Items.Items.Restrict(UnRead = True)
    For Each objMsg In Items

    Set objAttachments = objMsg.Attachments
    lngCount = objAttachments.Count

    If lngCount > 0 Then

    ' Use a count down loop for removing items
    ' from a collection. Otherwise, the loop counter gets
    ' confused and only every other item is removed.

    dtDate = objMsg.SentOn

    sName = Format(dtDate, "yyymmdd", vbUseSystemDayOfWeek, vbUseSystem) & Format(dDate, "hhnnss", vbUseSystemDayOfWeek, vbUseSystem) & "-"

    For i = lngCount To 1 Step -1

    ' 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

    Next i
    End If

    Next

    ExitSub:

    Set objAttachments = Nothing
    Set objMsg = Nothing
    Set Items = Nothing
    Set objOL = Nothing
    End Sub

    Any help will be greatly appreciated.

  37. James says

    Diane,

    Thank you for the quick response. I read the article you mentioned regarding the itemadd code, but I am brand new to vba coding in Outlook and cannot figure out how to make this command work with my existing code.
    Could you please provide me with an example or suggest where to add the itemadd line?
    This is all very new to me and I'm having a hard time figuring it out.

    James

  38. Daryl Berman says

    Hi Diane,

    I wonder if you can assist me, I am new to coding and came across you code for saving the attachments. I receive hundreds of reports (xls attachments) every month from a client of mine. The reports all have the same name, "BC Region Recon" followed by the date. What I need to have happen is for your code to save each report into a folder relating to text (customer name) from the body of the email (eg "Joe Blow") located in the 3rd line of the body of the email. Each email will have a different customer name as they relate to different customers of mine. If the folder does not exist I need the program to create it and save that attachment there and then move forward to the next email message.

    In other words I need the code to save the attachments in different folders under say your OLAttachments folder.

    Is this doable and could you possibly assist me?

    • Diane PoremskyDiane Poremsky says

      You need to create subfolders for each person -
      set strfolderpath variable then create the folder -
      Dim FSO As Object
      Set FSO = CreateObject("Scripting.FileSystemObject")
      If Not FSO.FolderExists(StrFolderPath) Then
      FSO.CreateFolder (StrFolderPath)
      End If

  39. Stig says

    Hi Diane
    Thank you so much for your efforts here - VBA is completely new to me, but your examples have helped me immensely in my daily work.

    I was wondering if it is possible to add the created/modified date from the attachment itself instead of the SentOn date of the message?

    I ask because I often receive delayed forwards of e.g. daily reports and similar, and I would prefer to be able to save it by the creation date of the report rather than the date the forward was sent (here I assume that you cannot extract date of original message instead of forwarded message).

    Thanks,
    Stig

    • Diane PoremskyDiane Poremsky says

      You can get the properties of the attachment but depending on the attachment type, it might be the received or saved time. Office docs may have the original modified date but for other attachments, the created/modified date is the date you handled it, not the date from the sender's computer.

    • Diane PoremskyDiane Poremsky says

      Try adding this right after the saveasfile line - turn on the Immediate window and see if the dates are the ones you expect.
      Dim FSO As Object: Set FSO = CreateObject("Scripting.FileSystemObject")
      Dim objFile As Object: Set objFile = FSO.Getfile(strFile)
      Debug.Print "Date created: " & objFile.DateCreated
      Debug.Print "Date last modified: " & objFile.DateLastModified

    • Stig says

      Thank you so much for getting back to me on this one. I've added your code snippet and it seems to collect the right date (tested on pdf, doc, xls, and dwg files). As far as I can see, your code "reads" the file created by the previous code - do you have a suggestion on how I should go about adding the DateLastModified to the name instead of the SentOn date?

    • Stig says

      That's perfect, Diane. Just what I was after!
      Once again, many, many thanks for your efforts here - you are saving me loads of time in my daily work with these snippets!

  40. JoJo says

    Hi Diane,

    Thank you so much for your tutorial. But i have a problem, the attachments I want to save are all ion same name, and actually it is generated from my system so with almost the same time, so I cannot use the date/time to distinguish them, can it add a number 1,2,3....to the file name end? could you help me on it? Thank you!

    my attachment all in this name: M3_PROD@manfrotto.com.pdf

  41. JoJo says

    Hi Diane,

    Many thanks! May I know is it possible to add the number before the file type".pdf"? As now I need to open the file by select Adobe every time before I could print it. If it could save as pdf file will be much more time saving for me. Thanks again for your great help!

    • Diane PoremskyDiane Poremsky says

      It's easiest if you put it before or after the filename, but there are a few ways to split it - assuming the only dot in the filename is before the extension, you can use this:
      ' Get the file name.
      strFile = objAttachments.Item(i).fileName

      Dim strExt() As String
      strExt() = Split(strFile, ".")
      For s = LBound(strExt) To UBound(strExt)
      pre = strExt(0)
      ext = strExt(1)
      Next

      ' Combine with the path to make the final path
      strFile = strFolderpath & pre & "_" & lRegValue & "." & ext

      If the filename might have a dot in it, you'd need to split it using left and right functions. The advantage of the first method is that it works with 3 and 4 digit extensions. With this, you would need to get the position of the last dot and use it in the len calculation.
      ' Get the file name.
      strFile = objAttachments.Item(i).fileName
      pre = Left(strFile, Len(strFile) - 4)
      ext = Right(strFile, 4)
      ' Combine with the path to make the final path
      strFile = strFolderpath & pre & "_" & lRegValue & ext

  42. Joel says

    Hi,
    I get a lot of pictures from a photographer, he writes the details in the email body.
    Is there a way to save each email in a separate folder, the name should be the subject line?
    and the email body should be saved as a text file?

  43. Diane PoremskyDiane Poremsky says

    This part starts it when Outlook is started and tells the macro to watch the default calendar folder. It should run every time an appointment is added to the calendar.

    Private Sub Application_Startup()
    Dim Ns As Outlook.NameSpace
    Set Ns = Application.GetNamespace("MAPI")
    Set Items = Ns.GetDefaultFolder(olFolderCalendar).Items
    End Sub

    Is macro security set to low?

Leave a Reply

Please post long or more complicated questions at OutlookForums by Slipstick.com.

If the Post Comment button disappears, press your Tab key.