Outlook 365 中的自动保存附件 [英] Auto Save attachment from Outlook 365

问题描述

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

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

我在收件箱中有专门的子文件夹，其中包含主题字符串销售报告"中的所有电子邮件.必须移动.我尝试创建规则 - 当收到电子邮件时，将其移动到子文件夹，然后运行允许保存附件的 VBA 脚本.然而，它有时不起作用，而不是保存 xls 文件，脚本正在保存文件正在进行的 ATP 扫描".在内置 Outlook 扫描程序扫描文件之前，脚本似乎正在保存 xls 文件.

有什么办法可以延迟保存 xls 直到扫描完成，或者有其他方法可以达到我的目标.

感谢您的支持.

Public Sub SaveAttachmentsToDisk(MItem As Outlook.MailItem)Dim oAttachment 作为 Outlook.AttachmentDim sSaveFolder As StringsSaveFolder = "\\reports\jon\";对于 MItem.Attachments 中的每个 oAttachmentoAttachment.SaveAsFile sSaveFolder &o附件.显示名称下一个结束子

解决方案

这样的事情应该可行...

<块引用>

在这个OutlookSession中

Private WithEvents ReportItems 作为 Outlook.Items私有子 Application_Startup()出错时继续下一步使用 Outlook.ApplicationSet ReportItems = .GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Folders("Sales Reports").Items结束于结束子Private Sub ReportItems_ItemAdd(ByVal Item As Object)出错时继续下一步如果 TypeName(Item) = "MailItem"然后调用 SaveXLSAttachments(Item, "\\reports\jon\")结束子

<块引用>

在一个模块中

Sub SaveXLSAttachments(ByVal Item As Object, FilePath As String)Dim i As Long, FileName As String, Extension As String如果正确(文件路径，1)<>\"然后 FilePath = FilePath &\"Delay(5) '如果需要扩展名 =.xls"带有 Item.Attachments如果 .Count >0 那么对于 i = 1 到 .Count文件名 = 文件路径 &.Item(i).文件名If LCase(Right(FileName, Len(Extension))) = Extension Then .Item(i).SaveAsFile FileName接下来我万一结束于结束子功能延迟(秒为单)将停止时间调暗为双倍:停止时间 = 计时器 + 秒做 While 计时器 <停止时间事件环形结束函数

I tried to approach my goal using in-build Outlook rules however without success so I decide to use VBA script but it is not also working properly.

Scenario: Every 1h I am reciving email with report in xls format, which need to be saved on share folder. Every 1h report can be overridden by new one. I don't need any date and time in file name just save file which was received.

I have dedicated sub folder in inbox, where all emails which contains in topic string "Sales Report" have to be moved. I tried to create rule - when email is recive then move it to subfolder, and afterward run VBA scrip which allows to save attachment. However it is not working as sometimes instead of saving xls file, script is saving file "ATP Scan In Progress". Looks like script is saving xls file before file was scanned by in-built Outlook scanner.

Is there any way to delay saving xls until scan will be completed, or there is any other way to aproach my goal.

Thank you for support.

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

解决方案

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

这篇关于Outlook 365 中的自动保存附件的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！