文件扫描完成后自动保存附件

Question

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

我的收件箱中有一个子文件夹，用于移动主题字符串中包含“销售报告”的所有电子邮件。我创建了一条规则 - 收到电子邮件后将其移至子文件夹，然后运行 VBA 脚本来保存附件。

有时，脚本不是保存 xls 文件，而是保存文件“ATP Scan In Progress”。看起来脚本是在内置 Outlook 扫描仪扫描文件之前保存的。

有什么方法可以延迟保存直到扫描完成，或者有其他方法可以实现我的目标吗？

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

这样的东西应该有效...

在本次展望会议中

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