Download .csv attachments from Today - vba

I want to download 4 unique csv files that I receive daily. So I need to download these 4 automatically. As of now, I can download all csv files but I can't limit it to only today's date.
This is my current code.
Public Sub SaveAutoAttach(item As Outlook.MailItem)
Dim object_attachment As Outlook.Attachment
Dim saveFolder As String
saveFolder = "C:\Desktop\Automatic Outlook Downloads"
For Each object_attachment In item.Attachments
If InStr(object_attachment.DisplayName, ".csv") Then
'If Int(object_attachment.ReceivedTime) = Date Then
object_attachment.SaveAsFile saveFolder & "\" & object_attachment.DisplayName
End If
'End If
Next
End Sub

I was able to answer my own question. Below is my modified code.
Public Sub SaveAutoAttach(item As Outlook.MailItem)
Dim olApp As Object
Dim olNS As Object
Dim myDate As Date
Dim olItems As Object
Dim olItem As Object
Dim olAttach As Object
On Error Resume Next
Set olApp = GetObject(, "Outlook.Application")
Err.Clear: On Error GoTo 0
If olApp Is Nothing Then
Set olApp = CreateObject("Outlook.Application")
Flg = True
End If
Set olNS = olApp.GetNamespace("MAPI")
Set olItems = olNS.GetDefaultFolder(olFolderInbox).Items
For Each olItem In olItems
If olItem.ReceivedTime > Date Then
On Error GoTo Finished
Set olAttach = olItem.Attachments.item(1)
Err.Clear: On Error GoTo 0
If Not olAttach Is Nothing Then
If olAttach.FileName Like "*.csv" Then
On Error GoTo Finished
olAttach.SaveAsFile "C:\Desktop\Automatic Outlook Downloads" & "\" & olAttach.FileName
Set olAttach = Nothing
Set olItem = Nothing
End If
End If
End If
Next

Related

how can i direct to another mailbox and also pull xlsm file only

please help, trying to change my default folder to another mailbox and also only pull csv files, based on different subject filters. below is my code. i am getting error if i use displayname to set object. and currently its pulling from my inbox. will really appreciate your assistance
Public Sub Download_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, sFolderName As String
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
saveFolder = "C:\Users\pmulei\Desktop\test" & "\" & sFolderName
subjectFilter = "Price"
displayname = "xlsm"
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 Err_Control
If outApp Is Nothing Then
MsgBox "Cannot start Outlook.", vbExclamation
Exit Sub
End If
Set outNs = outApp.GetNamespace("MAPI")
Set outFolder = outNs.Folders.outItem("Global Real Time").Folder.outItem("Inbox")
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
If outMailItem.ReceivedTime >= Date Then
For Each outAttachment In outMailItem.Attachments
If Dir(saveFolder, vbDirectory) = "" Then fso.CreateFolder (saveFolder)
If InStr(outAttachment.filename, displayname) > 0 Then
outAttachment.SaveAsFile saveFolder & outAttachment.filename
Set outAttachment = Nothing
Next
End If
End If
End If
End If
Next
End If
If OutlookOpened Then outApp.Quit
Set outApp = Nothing
Err_Control:
If Err.Number <> 0 Then
MsgBox Err.Description
End If
End Suenter code here
It's a good practice to ident the code properly. Try to replace this part of your code.
Set outNs = outApp.GetNamespace("MAPI")
Set outFolder = outNs.Folders.Item("Global Real Time").Folders.Item("Inbox")
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
If outMailItem.ReceivedTime >= Date Then
For Each outAttachment In outMailItem.Attachments
If Dir(saveFolder, vbDirectory) = "" Then fso.CreateFolder (saveFolder)
If InStr(outAttachment.Filename, DisplayName) > 0 Then
outAttachment.SaveAsFile saveFolder & outAttachment.Filename
Set outAttachment = Nothing
End If
Next
End If
End If
End If
Next
End If

Run Time Error '440'; Array index out of bounds, when referencing attachment by index

I have an Outlook rule to run a script to save attachments.
I insert an Err.Clear right after Set olAttach = olItem.Attachments.item(1) to clear an error in the code but this eventually causes the rule to fail.
When I don't have the Err.Clear command the code stops and gives
Run Time Error '440'; Array index out of bounds.
Public Sub April26(item As Outlook.MailItem)
'
Dim olApp As Object
Dim olNS As Object
Dim myDate As Date
Dim olItems As Object
Dim olItem As Object
Dim olAttach As Object
On Error Resume Next
Set olApp = GetObject(, "Outlook.Application")
Err.Clear: On Error GoTo 0
If olApp Is Nothing Then
Set olApp = CreateObject("Outlook.Application")
Flg = True
End If
Set olNS = olApp.GetNamespace("MAPI")
Set olItems = olNS.GetDefaultFolder(olFolderInbox).Items
For Each olItem In olItems
If olItem.ReceivedTime > Date Then
If InStr(olItem.Body, "Michael Jordan") > 0 Then
Set olAttach = olItem.Attachments.item(1) '<---
'Err.Clear: On Error GoTo 0 '<---
If Not olAttach Is Nothing Then
On Error GoTo Finished
olAttach.SaveAsFile "C:\Users\Desktop\Outlook Downloads" & "\" & olAttach.FileName
Set olAttach = Nothing
Set olItem = Nothing
End If
End If
End If
Next
Set olApp = Nothing
Set olNS = Nothing
Set olItems = Nothing
Finished:
Exit Sub
End Sub
So I was able to answer my question. The conditions of my code were to save the attachments from emails with "Michael Jordan" in the body. These emails were only sent out on the early morning (between 12 AM and 6 AM). I know that I there are only FOUR emails sent and each email has ONE attachment so I put a break in my loop once I have a total count for four attachments.
Below is my modified code
Public Sub April26(item As Outlook.MailItem)
'
Dim olApp As Object
Dim olNS As Object
Dim myDate As Date
Dim olItems As Object
Dim olItem As Object
Dim olAttach As Object
Dim Date1 As String
Dim Date2 As String
Dim iAttachments As Integer
Date1 = Date & " " & TimeValue("6:00:00")
Date2 = Date & " " & TimeValue("00:00:00")
On Error Resume Next
Set olApp = GetObject(, "Outlook.Application")
Err.Clear: On Error GoTo 0
If olApp Is Nothing Then
Set olApp = CreateObject("Outlook.Application")
Flg = True
End If
Set olNS = olApp.GetNamespace("MAPI")
Set olItems = olNS.GetDefaultFolder(olFolderInbox).Items
For Each olItem In olItems
If olItem.ReceivedTime < Date1 Then
If olItem.ReceivedTime > Date2 Then
If InStr(olItem.Body, "Michael Jordan") > 0 Then
'MsgBox (olItem & " " & olItem.ReceivedTime)
iAttachments = olItem.Attachments.Count + iAttachments
Set olAttach = olItem.Attachments.item(1)
On Error GoTo Err_Handler
olAttach.SaveAsFile "C:\Desktop\Outlook Downloads" & "\" & olAttach.FileName
Set olAttach = Nothing
Set olItem = Nothing
If iAttachments = 4 Then Exit For
End If
End If
End If
Next
Set olAttach = Nothing
Set olItem = Nothing
Set olApp = Nothing
Set olNS = Nothing
Set olItems = Nothing
Exit Sub
Err_Handler:
MsgBox "An unexpected error has occurred." _
& vbCrLf & "Please note and report the following information to Darth Vader." _
& vbCrLf & "Macro Name: April26" _
& vbCrLf & "Error Number: " & Err.Number _
& vbCrLf & "Error Description: " & Err.Description _
, vbCritical, "Error!"
Exit Sub
End Sub
The error is due to there being no attachments.
With On Error Resume Next anticipated errors are bypassed. Since they are anticipated you will know how to handle them, or ignore if reasonable to do so.
Option Explicit
' Extra lines for running code from applications other than Outlook removed
Public Sub April26(olItem As MailItem)
Dim myDate As Date
Dim olAttach As Attachment
If olItem.ReceivedTime > Date Then
If InStr(olItem.Body, "Michael Jordan") > 0 Then
' Rare beneficial use of "On Error Resume Next"
On Error Resume Next
' Bypass error if there is no attachment
Set olAttach = olItem.Attachments.item(1)
'If there is an error olAttach remains whatever it was before
' In this case it is the initial value of Nothing
' Remove error bypass as soon as the purpose is served
On Error GoTo 0
If Not olAttach Is Nothing Then
olAttach.SaveAsFile "C:\Users\Desktop\Outlook Downloads" & "\" & olAttach.fileName
' If this type of error handling is in a loop,
' reinitialize
' Set olAttach = Nothing
End If
End If
End If
End Sub

Save Attachment on arriving email

I created an Outlook rule to save an attachment then move it to the Deleted Items folder. The code works when I highlight the arrived email in the Inbox then move the email to the Deleted Items folder.
When the new email arrives, it is saving the attachment(s) from different email in the inbox and not moving the email to the Deleted Items folder.
The Outlook rule is:
Apply this rule after the message arrives
from Sender
and with Gift Card in the subject
and on this computer only
run Project1.SaveAttachments
Public Sub SaveAttachments(MItem 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 objNamespace As Outlook.NameSpace
Dim objDestFolder As Outlook.MAPIFolder
On Error Resume Next
Set objOL = CreateObject("Outlook.Application")
Set objSelection = objOL.ActiveExplorer.Selection
strFolderpath = "Y:\"
For Each objMsg In objSelection
Set objAttachments = objMsg.Attachments
lngCount = objAttachments.Count
strDeletedFiles = ""
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
Set objNamespace = objOL.GetNamespace("MAPI")
Set objDestFolder = objNamespace.GetDefaultFolder(olFolderDeletedItems)
objMsg.Move objDestFolder
End If
Next
Set objAttachments = Nothing
Set objMsg = Nothing
Set objSelection = Nothing
Set objOL = Nothing
Set objNamespace = Nothing
Set objDestFolder = Nothing
End Sub
According to my test, you could save email attachment and delete it using the below code:
Sub SaveAutoAttach()
Dim object_attachment As Outlook.attachment
Dim saveFolder As String
Dim oOutlook As Object
Dim oOlns As Object
Dim oOlInb As Object
Dim unRead, m As Object, att As Object
Dim some As String, other As String
Const olFolderInbox = 6
'~~> Get Outlook instance
Set oOutlook = GetObject(, "Outlook.application")
Set oOlns = oOutlook.GetNamespace("MAPI")
Set oOlInb = oOlns.GetDefaultFolder(olFolderInbox)
'~~> Check if there are any actual unread emails
Set unRead = oOlInb.Items.Restrict("[UnRead] = True")
If unRead.Count = 0 Then
MsgBox "NO Unread Email In Inbox"
Else
some = ""
other = ""
saveFolder = "D:\"
For Each m In unRead
If m.Attachments.Count > 0 Then
For Each object_attachment In m.Attachments
' Criteria to save .doc files only
If InStr(object_attachment.DisplayName, ".doc") Then
object_attachment.SaveAsFile saveFolder & "\" & object_attachment.DisplayName
End If
Next
End If
m.Delete
Next m
End Sub
For more information, please refer to this link:
Auto Download Outlook Email Attachment – Code in VBA by Topbullets.com

My VBA loop is not starting at the beginning of a subfolder in Outlook

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.

Run-time Error 424 Object Required

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