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

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 > 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 & 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

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

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  amp       amp  dateFormat  amp  objAtt DisplayName     Next End Sub   Thanks a ton for the other solutions  many of them go above an beyond

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

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

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

[vba] Save attachments to a folder and rename them

Examples related to vba

Examples related to outlook

Examples related to attachment