Auto Save attachment after file scan completed

Question

Every hour I receive an email with a report in xls format, to be saved in a shared folder. Every report can be overwritten by the new one. I don't need date and time in the file name.

I have a subfolder in my inbox, to move all emails which contain "Sales Report" in the topic string. I created a rule - when email is received move it to the subfolder, and afterward run a VBA script to save the attachment.

Sometimes instead of saving the xls file, the script is saving file "ATP Scan In Progress". Looks like the script is saving before the file was scanned by the in-built Outlook scanner.

Is there any way to delay saving until the scan is complete, or another way to approach my goal?

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

Answer 1

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