根据标题自动保存 outlook 附件

Question

我希望建立一个单驱动器文件夹，用于为我们公司的各种客户保存报告。我们的报告软件只发送到电子邮件而不是保存到文件所以我用谷歌搜索并找到这段代码自动下载所有附件到一个文件夹

Public Sub saveAttachtoDisk(itm As Outlook.MailItem)
Dim objAtt As Outlook.Attachment
Dim saveFolder As String
Dim dateFormat
    dateFormat = Format(Now, "yyyy-mm-dd H-mm")
saveFolder = "C:\Report Attachments\"
     For Each objAtt In itm.Attachments
         objAtt.SaveAsFile saveFolder & "\" & dateFormat & objAtt.DisplayName
          Set objAtt = Nothing
     Next
End Sub

问题是我想按公司拆分报告。例如，我希望 A 公司的报告转到

C:\报告Attachments\Company一个

并报告 B 公司去

C:\报告Attachments\CompanyB

等等。每个报告应该在附件标题中包含公司名称，因此我正在寻找对代码的调整以根据附件标题更改保存位置。这可能吗？

Answer 1

设置规则以在电子邮件到达时将其移动到特定文件夹（可能是基于电子邮件地址域的规则）。

在 Outlook 的 ThisOutlookSession 模块中，在声明部分输入此代码：

Dim WithEvents CompanyA As Items
Dim WithEvents CompanyB As Items

Const COMPA_PATH As String = "C:\Report Attachments\Company A\"
Const COMPB_PATH As String = "C:\Report Attachments\Company B\"

Private Sub Application_Startup()

    Dim ns As Outlook.NameSpace
    Set ns = Application.GetNamespace("MAPI")

    Set CompanyA = ns.Folders.item("Mailbox - tomdemaine") _
                        .Folders.item("Inbox") _
                        .Folders.item("CompanyA").Items

    Set CompanyB = ns.Folders.item("Mailbox - tomdemaine") _
                        .Folders.item("Inbox") _
                        .Folders.item("CompanyA").Items

End Sub

Sub CompanyA_ItemAdd(ByVal item As Object)

    Dim oAtt As Attachment

    If item.Attachments.Count > 0 Then
        For Each oAtt In item.Attachments
            item.UnRead = False
            'Note DisplayName may contain illegal characters.
            oAtt.SaveAsFile COMPA_PATH & oAtt.DisplayName
            DoEvents
        Next oAtt
    End If

    Set oAtt = Nothing

End Sub

Sub CompanyB_ItemAdd(ByVal item As Object)

    Dim oAtt As Attachment

    If item.Attachments.Count > 0 Then
        For Each oAtt In item.Attachments
            item.UnRead = False
            'Note DisplayName may contain illegal characters.
            oAtt.SaveAsFile COMPB_PATH & oAtt.DisplayName
            DoEvents
        Next oAtt
    End If

    Set oAtt = Nothing

End Sub

当您启动 Outlook 时，该代码将开始监视您的 CompanyA 和 CompanyB 文件夹。任何时候将包含附件的东西移到那里时，它会将它们保存到您的文件位置并将电子邮件标记为已读。

我没有测试代码 - Outlook 文件夹和文件位置需要更新以满足您的需要。

根据标题自动保存 outlook 附件

Automatically saving outlook attachments based on title

vba

outlook

email-attachments