Save attachments to a folder and rename them
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
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/
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
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) <> "\" Then saveFolder = saveFolder & "\"
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 <> 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) > 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
Next
End If
If OutlookOpened Then outApp.Quit
Set outApp = Nothing
End Sub