Autosave Outlook mail & its Attachments to Excel via VBA

Question

I want to Save outlook Attachments from mails after Specific date via VBA. But my code is not doing anything. Someone Please tell what wrong am i doing ? I am using Office 365.

I wrote following code but not solving the issue:-

`Option Explicit
Const AttachmentPath As String = "C:\myattachments\"
Sub GetFromOutlook()
Dim OutlookAtch As Object
Dim NewfileName As String
NewfileName = AttachmentPath & Format(Date, "DD-MM-YYYY") & "-"
Dim OutlookApp As Outlook.Application
Dim OutlookNamespace As Namespace
Dim Folder As MAPIFolder
Dim OutlookMail As Variant
Dim i As Integer
Dim col As Long
col = 0
Set OutlookApp = New Outlook.Application
Set OutlookNamespace = OutlookApp.GetNamespace("MAPI")
Set Folder =OutlookNamespace.GetDefaultFolder(olFolderInbox).Folders("IT").Folders("Compliance").Folders("Inventory")

i = 1

For Each OutlookMail In Folder.Items
If OutlookMail.Attachments.Count > 0 Then
For Each OutlookAtch In OutlookMail.Attachments

If OutlookMail.ReceivedTime >= Range("From_date").Value Then
    Range("Email_Subject").Offset(i, 0).Value = OutlookMail.Subject
    Range("Email_Date").Offset(i, 0).Value = OutlookMail.ReceivedTime
    Range("Email_Sender").Offset(i, 0).Value = OutlookMail.SenderName
    Range("Email_Text").Offset(i, 0).Value = OutlookMail.Body
    OutlookAtch.SaveAsFile NewfileName & OutlookAtch.Filename
    Range("Email_Attch").Offset(i, 0).Value = OutlookAtch
    col = col + 1
    End If
Next OutlookAtch
col = 0
       i = i + 1
End If
Next OutlookMail
Set Folder = Nothing
Set OutlookNamespace = Nothing
Set OutlookApp = Nothing
End Sub`

You could check the received time *before* looping over the attachments... Also only increment `i` when you write information to the sheet. — Tim Williams, Jun 16 '23 at 16:35
@EugeneAstafiev - agreed, but still the OP may not change their approach unless you show them exactly how to do that... — Tim Williams, Jun 16 '23 at 21:31

Eugene Astafiev · Answer 1 · 2023-06-19T20:54:30.927

But my code is not doing anything. Someone Please tell what wrong am i doing ?

You need to run the code under the debugger attached to find out what is wrong and why files are not saved to the disk. I may only assume that Outlook folders may contain different kind of items. So, before accessing any type-specific properties and methods you need to check the item type first in the loop. You can do that in the following ways:

If TypeOf objFolder.Items(i) Is MailItem Then
      Set objMailItem = objFolder.Items(i)

or

 If TypeName(Item) = "MailItem" Then
    Set oItem = Item

Also, instead of iterating over all items in the folder and checking the ReceivedTime property of items:

For Each OutlookMail In Folder.Items
If OutlookMail.Attachments.Count > 0 Then
For Each OutlookAtch In OutlookMail.Attachments

If OutlookMail.ReceivedTime >= Range("From_date").Value Then

You need to use the Find/FindNext or Restrict methods of the Items class. They allow getting items that correspond to the specified search criteria and iterate only over them. You can read more about these methods in the following articles that I wrote for the technical blog:

To search items with attachments you can use the following search criteria:

Filter = "@SQL=" & Chr(34) & "urn:schemas:httpmail:hasattachment" & _
                   Chr(34) & "=1"

You can combine multiple search criteria in the single search string by using logical operators like AND or OR.

To filter items by the received time you can use following filters, for example:

    'This filter uses DASL date macro for today 
    strFilter = "%today(" _ 
    & AddQuotes("urn:schemas:httpmail:datereceived") & ")%" 
     
    'or 

    'This filter uses urn:schemas:httpmail namespace 
    strFilter = AddQuotes("urn:schemas:httpmail:datereceived") _ 
    & " > '" & datStartUTC & "' AND " _ 
    & AddQuotes("urn:schemas:httpmail:datereceived") _ 
    & " < '" & datEndUTC & "'"

where AddQuotes looks like that:

Public Function AddQuotes(ByVal SchemaName As String) As String 
    On Error Resume Next 
    AddQuotes = Chr(34) & SchemaName & Chr(34) 
End Function

Autosave Outlook mail & its Attachments to Excel via VBA

1 Answers1