自动保存来自 Outlook 365 的附件

Question

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

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

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

像这样的东西应该有用...

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

自动保存来自 Outlook 365 的附件

Auto Save attachment from Outlook 365

excel

outlook

vba

script