Auto Save attachment from Outlook 365

Question

I tried to approach my goal using in-build Outlook rules however without success so I decide to use VBA script but it is not also working properly.

Scenario: Every 1h I am reciving email with report in xls format, which need to be saved on share folder. Every 1h report can be overridden by new one. I don't need any date and time in file name just save file which was received.

I have dedicated sub folder in inbox, where all emails which contains in topic string "Sales Report" have to be moved. I tried to create rule - when email is recive then move it to subfolder, and afterward run VBA scrip which allows to save attachment. However it is not working as sometimes instead of saving xls file, script is saving file "ATP Scan In Progress". Looks like script is saving xls file before file was scanned by in-built Outlook scanner.

Is there any way to delay saving xls until scan will be completed, or there is any other way to aproach my goal.

Thank you for support.

Public Sub SaveAttachmentsToDisk(MItem As Outlook.MailItem)
Dim oAttachment As Outlook.Attachment
Dim sSaveFolder As String
sSaveFolder = "\\reports\jon\"
For Each oAttachment In MItem.Attachments
oAttachment.SaveAsFile sSaveFolder & oAttachment.DisplayName
Next
End Sub

Tragamor Tragamor · Accepted Answer · 2021-03-25T12:08:10

Something like this should work...

In ThisOutlookSession

Private WithEvents ReportItems As Outlook.Items

Private Sub Application_Startup()
    On Error Resume Next
    With Outlook.Application
        Set ReportItems = .GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Folders("Sales Reports").Items
    End With
End Sub

Private Sub ReportItems_ItemAdd(ByVal Item As Object)
    On Error Resume Next
    If TypeName(Item) = "MailItem" Then Call SaveXLSAttachments(Item, "\\reports\jon\")
End Sub

In a module

Sub SaveXLSAttachments(ByVal Item As Object, FilePath As String)
    Dim i As Long, FileName As String, Extension As String
    If Right(FilePath, 1) <> "\" Then FilePath = FilePath & "\"
    
    Delay(5)  'If required
    Extension = ".xls"
    With Item.Attachments
        If .Count > 0 Then
            For i = 1 To .Count
                FileName = FilePath & .Item(i).FileName
                If LCase(Right(FileName, Len(Extension))) = Extension Then .Item(i).SaveAsFile FileName
            Next i
        End If
    End With
End Sub

Function Delay(Seconds As Single)
    Dim StopTime As Double: StopTime = Timer + Seconds
    Do While Timer < StopTime
        DoEvents
    Loop
End Function

Auto Save attachment from Outlook 365

1 Answers