从 Outlook 365 自动保存附件

Question

我尝试使用内置 Outlook 规则来接近我的目标，但是没有成功，所以我决定使用 VBA 脚本，但它也不能正常工作。

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

我在收件箱中有专门的子文件夹，其中包含主题字符串“销售报告”的所有电子邮件都必须移动。 我尝试创建规则 - 当 email 被接收然后将其移动到子文件夹，然后运行 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