I am trying to save all attachemnts from emails that arrived today.
I do not know how to reference the date property of an email object.
My existing code:
Sub GetAllAttachments() 'Exports and saves all attachements in the inbox
Dim ns As NameSpace
Dim Inbox As MAPIFolder
Dim Item As Object
Dim Atmt As Attachment
Dim FileName As String
Dim i As Integer
Today = Format(Now(), "yyyy MM dd")
Set ns = GetNamespace("MAPI")
Set Inbox = ns.Folders("Secondary")
Set Inbox = Inbox.Folders("Inbox")
i = 0
If Inbox.Items.Count = 0 Then
MsgBox "There are no messages in the Inbox.", vbInformation, _
"Nothing Found"
Exit Sub
End If
For Each Item In Inbox.Items
If EMAIL_DATE = Today Then
For Each Atmt In Item.Attachments
FileName = "C:\Email Attachments\" & Atmt.FileName
Atmt.SaveAsFile FileName
i = i + 1
End If
Next Atmt
Next Item
End Sub
Item doesn't have the date property.
Try using the
Outlook.MailItem
For example:
Dim oMI as Outlook.MailItem
For Each oMI in Application.ActiveExplorer.Selection
Msgbox (oMI.RecievedTime)
Next
You will need to strip the date from the time.
Option Explicit ' Consider this mandatory
' Tools | Options | Editor tab
' Require Variable Declaration
' If desperate declare as Variant
Sub GetAllAttachments()
'Exports and saves all attachements in the inbox
Dim ns As namespace
Dim mailBox As folder
Dim myInbox As folder
Dim myItem As Object
Dim myItems As Items
Dim Atmt As Attachment
Dim FileName As String
Dim today As Date
today = Format(Now, "yyyy-mm-dd")
Debug.Print
Debug.Print Format(today, "yyyy-mm-dd hh:nn:ss AM/PM"), "midnight"
Set ns = GetNamespace("MAPI")
Set mailBox = ns.folders("Secondary")
Set myInbox = mailBox.folders("Inbox")
Set myItems = myInbox.Items
If myItems.Count = 0 Then
MsgBox "There are no messages in the Inbox.", vbInformation, _
"Nothing Found"
Exit Sub
End If
myItems.Sort "[ReceivedTime]", True
For Each myItem In myItems
If myItem.Class = olMail Then
If myItem.ReceivedTime > today Then
Debug.Print myItem.ReceivedTime, myItem.subject
For Each Atmt In myItem.Attachments
FileName = "C:\Email Attachments\" & Atmt.FileName
Atmt.SaveAsFile FileName
Next Atmt
Else
Debug.Print
Debug.Print myItem.ReceivedTime, "** Exiting - prior to today **"
Exit For
End If
Else
' Mailitem properties may not apply
Debug.Print "Not a mailitem."
End If
Next myItem
End Sub
Reference material for the Outlook object model.
https://learn.microsoft.com/en-us/office/vba/api/overview/outlook/object-model
MailItem.ReceivedTime Property:
https://learn.microsoft.com/en-us/office/vba/api/outlook.mailitem
Related
I want to autosave attachments from a sub-folder in Outlook.
I need to only save those in mail with a particular subject line (inStr) and the time received, like today.
I have code, but don't know how to add the conditionals, the subject and time received; and I would like to rename the Excel attachment when I save it.
Option Explicit
Const folderPath = "C:\Documents\nike\My Documents\emailTest\"
Sub CompanyChange()
On Error Resume Next
Dim ns As NameSpace
Set ns = GetNamespace("MAPI")
Dim Inbox As MAPIFolder
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
Dim searchFolder As String
searchFolder = InputBox("What is your subfolder name?")
Dim subFolder As MAPIFolder
Dim Item As Object
Dim Attach As Attachment
Dim FileName As String
Dim i As Integer
If searchFolder <> "inbox" Then
Set subFolder = Inbox.Folders(searchFolder)
i = 0
If subFolder.Items.Count = 0 Then
MsgBox "There are no messages in the Inbox.", vbInformation, _
"Nothing Found"
Exit Sub
End If
For Each Item In subFolder.Items
For Each Attach In Item.Attachments
Attach.SaveAsFile (folderPath & Attach.FileName)
i = i + 1
Next Attach
Next Item
Else
i = 0
If Inbox.Items.Count = 0 Then
MsgBox "There are no messages in the Inbox.", _
vbInformation, "Nothing Found"
Exit Sub
End If
On Error Resume Next
For Each Item In Inbox.Items
For Each Attach In Item.Attachments
FileName = folderPath & Attach.FileName
Attach.SaveAsFile FileName
i = i + 1
Next Attach
Next Item
End If
End Sub
Like this:
Place your if condition before the loop that is saving your files.
For Each Item In subFolder.Items
If Item.Subject = "Subject you want to Macth with" Then 'Condition
For Each Attach In Item.Attachments
Attach.SaveAsFile (folderPath & Attach.FileName)
i = i + 1
Next Attach
End If
Next Item
I have the below code that runs through a folder looking for unread messages from a specific person with a specific subject. The loop is not beginning at the most recent emails. It's beginning a month ago where all the messages are read.
Sub MovingAttachmentsIntoNetworkFolders()
Dim olApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Dim olFolder As Outlook.MAPIFolder
Set olApp = Outlook.Application
Set objNS = olApp.GetNamespace("MAPI")
Set olFolder = objNS.GetDefaultFolder(olFolderInbox).Folders("Email Subfolder") 'Specify Folder here
On Error GoTo ErrorHandler
For Each Item In olFolder.Items
Debug.Print Item.ReceivedTime
If Item.UnRead = True Then
If TypeOf Item Is Outlook.MailItem Then
Dim oMail As Outlook.MailItem: Set oMail = Item
Debug.Print Item.SenderEmailAddress
Debug.Print Item.Subject
Debug.Print Item.Attachments.Count
If Item.Sender = "emailaddress#email.com" And _
Item.Subject = "EmailSubject" And _
Item.Attachments.Count = 1 Then
'Set folder to save in.
Dim olDestFldr As Outlook.MAPIFolder
Dim myAttachments As Outlook.Attachments
Dim Att As String
'location to save in. Can be root drive or mapped network drive.
Const attPath As String = "mappednetworkdrive"
' save attachment
Set myAttachments = Item.Attachments
Att = myAttachments.Item(1).FileName
Debug.Print Att & "\" & Format(Item.ReceivedTime, "mm-dd-yyyy")
myAttachments.Item(1).SaveAsFile Format(Item.ReceivedTime, "mm.dd.yyyy") & " " & Att
' mark as read
Item.UnRead = False
End If
End If
End If
Next
ProgramExit:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ProgramExit
End Sub
Any reason why my code is behaving this way?
For a For Each loop, you can sort a collection of the items in the folder by ReceivedTime as described here Email data exported to Excel - Sort by Received Date
Note: Untested code to demonstrate how to sort
Option Explicit
Sub MovingAttachmentsIntoNetworkFolders()
Dim objNS As NameSpace
Dim olFolder As Folder
dim objItem as object
dim fldItems as items
Set objNS = GetNamespace("MAPI")
Set olFolder = objNS.GetDefaultFolder(olFolderInbox)
'Specify Folder here
Set olFolder = olFolder.Folders("Email Subfolder")
On Error GoTo ErrorHandler
' https://stackoverflow.com/questions/14948295/email-data-exported-to-excel-sort-by-received-date
set fldItems = olFolder.Items
fldItems.Sort "ReceivedTime", true
For Each objItem In fldItems
Debug.Print objItem.ReceivedTime
If objItem.UnRead = True Then
If TypeOf objItem Is MailItem Then
Debug.Print objItem.SenderEmailAddress
Debug.Print objItem.Subject
Debug.Print objItem.Attachments.Count
If objItem.Sender = "emailaddress#email.com" And _
objItem.Subject = "EmailSubject" And _
objItem.Attachments.Count = 1 Then
' mark as read
objItem.UnRead = False
End If
End If
End If
set objItem = Nothing
Next
ProgramExit:
Set objNS = Nothing
Set olFolder = Nothing
set fldItems = Nothing
set objItem = Nothing
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ProgramExit
End Sub
If code is in Outlook there is no need to reference Outlook.
Avoid using Item and olMail for variable names as they already have a purpose.
I want to download all attachments of Unread emails from my MS Outlook. I found this below mentioned code on StackExchange which downloads attachments from first Unread email.
Can any one modify this code so i can apply it on all Unread emails.
Const olFolderInbox As Integer = 6
'~~> Path for the attachment
Const AttachmentPath As String = "C:\"
Sub DownloadAttachmentFirstUnreadEmail()
Dim oOlAp As Object, oOlns As Object, oOlInb As Object
Dim oOlItm As Object, oOlAtch As Object
'~~> New File Name for the attachment
Dim NewFileName As String
NewFileName = AttachmentPath & Format(Date, "DD-MM-YYYY") & "-"
'~~> Get Outlook instance
Set oOlAp = GetObject(, "Outlook.application")
Set oOlns = oOlAp.GetNamespace("MAPI")
Set oOlInb = oOlns.GetDefaultFolder(olFolderInbox)
'~~> Check if there are any actual unread emails
If oOlInb.Items.Restrict("[UnRead] = True").Count = 0 Then
MsgBox "NO Unread Email In Inbox"
Exit Sub
End If
'~~> Extract the attachment from the 1st unread email
For Each oOlItm In oOlInb.Items.Restrict("[UnRead] = True")
'~~> Check if the email actually has an attachment
If oOlItm.Attachments.Count <> 0 Then
For Each oOlAtch In oOlItm.Attachments
'~~> Download the attachment
oOlAtch.SaveAsFile NewFileName & oOlAtch.Filename
Exit For
Next
Else
MsgBox "The First item doesn't have an attachment"
End If
Exit For
Next
End Sub
When using Items.Restrict Method (Outlook) you may want to set the Filter for both Attachment and UnRead Items, Filter = "[attachment] = True And [Unread] = True" then use a For...Next and loop backwards
Example:
Option Explicit
Public Sub Example()
'// Declare your Variables
Dim olNs As Outlook.NameSpace
Dim Inbox As Outlook.MAPIFolder
Dim Items As Outlook.Items
Dim Item As Outlook.MailItem
Dim Atmt As Attachment
Dim Filter As String
Dim FilePath As String
Dim AtmtName As String
Dim i As Long
'// Set Inbox Reference
Set olNs = Application.GetNamespace("MAPI")
Set Inbox = olNs.GetDefaultFolder(olFolderInbox)
FilePath = "C:\Temp\"
Filter = "[attachment] = True And [Unread] = True"
Set Items = Inbox.Items.Restrict(Filter)
'// Loop through backwards
For i = Items.Count To 1 Step -1
Set Item = Items(i)
DoEvents
If Item.Class = olMail Then
Debug.Print Item.Subject ' Immediate Window
For Each Atmt In Item.Attachments
AtmtName = FilePath & Atmt.FileName
Atmt.SaveAsFile AtmtName
Next
End If
Next
Set Inbox = Nothing
Set Items = Nothing
Set Item = Nothing
Set Atmt = Nothing
Set olNs = Nothing
End Sub
Much cleaner, batter & faster...
I created a rule to move emails to sub folders called "outgoing" and "incoming comments". I need to extract the attachments into automatically created local hard drive sub folders named with the subjects of the emails.
The local drive is F:\Outgoing
Loop through the Folder.Items collection and get MailItem objects from each item in the collection. Then for each MailItem, call Attachment.SaveAsFile for each object in MailItem.Attachments.
Option Explicit
Const folderPath = "f:\outgoing\"
Sub GetOutGoingAttachments()
On Error Resume Next
Dim ns As NameSpace
Set ns = GetNamespace("MAPI")
Dim Inbox As MAPIFolder
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
Dim searchFolder As String
searchFolder = InputBox("Search for Outgoing Reports?")
Dim Subfolder As MAPIFolder
Dim Item As Object
Dim Attach As Attachment
Dim FileName As String
Dim i As Integer
If searchFolder <> "inbox" Then
Set Subfolder = Inbox.Folders(searchFolder)
i = 0
If Subfolder.Items.Count = 0 Then
MsgBox "There are no messages in the Inbox.", vbInformation, _
"Nothing Found"
Exit Sub
End If
For Each Item In Subfolder.Items
For Each Attach In Item.Attachments
'
Attach.SaveAsFile (folderPath & Attach.FileName)
i = i + 1
Next Attach
Next Item
'==============================================================================
'to search specific type of file:
' 'For Each Item In Inbox.Items
' For Each Atmt In Item.Attachments
' If Right(Atmt.FileName, 3) = "xls" Then
' FileName = "C:\Email Attachments\" & Atmt.FileName
' Atmt.SaveAsFile FileName
' i = i + 1
' End If
' Next Atmt
' Next Item
'===============================================================================
Else
i = 0
If Inbox.Items.Count = 0 Then
MsgBox "There are no messages in the Inbox.", vbInformation, _
"Nothing Found"
Exit Sub
End If
On Error Resume Next
For Each Item In Inbox.Items
For Each Attach In Item.Attachments
FileName = folderPath & Attach.FileName
Attach.SaveAsFile FileName
i = i + 1
Next Attach
Next Item
End If
End Sub
Im writing a macro for outlook 2010. I get the error on the for each loop even the first time and oFolder does contain a folder.
BTW, SaveAttachments runs correctly the first time its just the second time it bombs.
Public Sub processFolder()
Set objNS = Application.GetNamespace("MAPI")
Dim oParent As Outlook.MAPIFolder
Dim oFolder As Outlook.MAPIFolder
Dim FolderName As String
Set objInbox = objNS.GetDefaultFolder(olFolderInbox)
SaveAttachments (objInbox)
If (objInbox.Folders.Count > 0) Then
For Each oFolder In objInbox.Folders
SaveAttachments (oFolder)
Next
End If
End Sub
Sub SaveAttachments(ByVal oParent As Outlook.MAPIFolder)
'Declaration
Dim myItems, myItem, myAttachments, myAttachment As Object
Dim myOrt As String
Dim myOlApp As New Outlook.Application
myOrt = "C:\attachments"
On Error Resume Next
'for all items do...
For Each myItem In oParent.Items
'point on attachments
Set myAttachments = myItem.Attachments
'if there are some...
If myAttachments.Count > 0 Then
'add remark to message text
myItem.Body = myItem.Body & vbCrLf & _
"Removed Attachments:" & vbCrLf
'for all attachments do...
For i = 1 To myAttachments.Count
'save them to destination
myAttachments(i).SaveAsFile myOrt & _
myAttachments(i).DisplayName
'add name and destination to message text
myItem.Body = myItem.Body & _
"File: " & myOrt & _
myAttachments(i).DisplayName & vbCrLf
Next i
'for all attachments do...
While myAttachments.Count > 0
'remove it (use this method in Outlook XP)
'myAttachments.Remove 1
'remove it (use this method in Outlook 2000)
myAttachments(1).Delete
Wend
'save item without attachments
myItem.Save
End If
Next
'free variables
Set myItems = Nothing
Set myItem = Nothing
Set myAttachments = Nothing
Set myAttachment = Nothing
Set myOlApp = Nothing
Set myOlExp = Nothing
Set myOlSel = Nothing
End Sub
You have mixed and matched the method of calling SaveAttachments
Choose one or the other
Call SaveAttachments(objInbox) ' <--- Call requires brackets
SaveAttachments objInbox ' <--- No brackets
SaveAttachments oFolder ' <--- No brackets