从 Outlook 365 自动保存附件

Question

我尝试使用内置 Outlook 规则来实现我的目标，但没有成功，因此我决定使用 VBA 脚本，但它也无法正常工作。

场景： 每隔 1 小时，我都会收到带有 xls 格式报告的电子邮件，这些报告需要保存在共享文件夹中。每 1 小时的报告都可以被新的报告覆盖。我不需要文件名中的任何日期和时间，只需保存收到的文件即可。

我在收件箱中有专门的子文件夹，其中包含主题字符串“销售报告”的所有电子邮件都必须移动。我尝试创建规则 - 当电子邮件被接收然后将其移动到子文件夹，然后运行允许保存附件的 VBA 脚本。但是它有时不工作，而不是保存 xls 文件，脚本正在保存文件“ATP Scan In Progress”。看起来脚本在内置 Outlook 扫描程序扫描文件之前保存 xls 文件。

有什么方法可以延迟保存 xls 直到扫描完成，或者有任何其他方法可以接近我的目标。

感谢您的支持。

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

这样的事情应该可以工作......

在此 Outlook 会话中

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

在一个模块中

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