Save attachments to a folder and rename them

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.ApplicationDim objMsg As Outlook.MailItem 'ObjectDim objAttachments As Outlook.AttachmentsDim objSelection As Outlook.SelectionDim i As LongDim lngCount As LongDim strFile As StringDim strFolderpath As StringDim strDeletedFiles As String' Get the path to your My Documents folderstrFolderpath = 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 IfNextExitSub:Set objAttachments = NothingSet objMsg = NothingSet objSelection = NothingSet objOL = NothingEnd Sub

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 & "\" & dateFormat & objAtt.DisplayName    NextEnd 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/

Public Sub Extract_Outlook_Email_Attachments()Dim OutlookOpened As BooleanDim outApp As Outlook.ApplicationDim outNs As Outlook.NamespaceDim outFolder As Outlook.MAPIFolderDim outAttachment As Outlook.AttachmentDim outItem As ObjectDim saveFolder As StringDim outMailItem As Outlook.MailItemDim inputDate As String, subjectFilter As StringsaveFolder = "Y:\Wingman" ' THIS IS WHERE YOU WANT TO SAVE THE ATTACHMENT TOIf Right(saveFolder, 1) <> "\" Then saveFolder = saveFolder & "\"subjectFilter = ("Daily Operations Custom All Req Statuses Report") ' THIS IS WHERE YOU PLACE THE EMAIL SUBJECT FOR THE CODE TO FINDOutlookOpened = FalseOn Error Resume NextSet outApp = GetObject(, "Outlook.Application")If Err.Number <> 0 Then    Set outApp = New Outlook.Application    OutlookOpened = TrueEnd IfOn Error GoTo 0If outApp Is Nothing Then    MsgBox "Cannot start Outlook.", vbExclamation    Exit SubEnd IfSet 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) > 0 Then 'removed the quotes around subjectFilter                    For Each outAttachment In outMailItem.Attachments                    outAttachment.SaveAsFile saveFolder & outAttachment.filename                    Set outAttachment = Nothing                    Next                End If        End If    NextEnd IfIf OutlookOpened Then outApp.QuitSet outApp = NothingEnd Sub