根据标题自动保存 Outlook 附件答案

【问题标题】：Automatically saving outlook attachments based on title根据标题自动保存 Outlook 附件
【发布时间】：2016-07-23 23:51:02
【问题描述】：

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

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:\Report Attachments\A 公司

和B公司的报告去

C:\Report Attachments\Company B

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

【问题讨论】：

标签： vba outlook email-attachments

【解决方案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 文件夹和文件位置需要更新以满足您的需求。

【讨论】：