根据标题

Question

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

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 \ Company A

并报告公司B前往

C：\ Report Attachments \ Company B

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

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

代码将开始关注您的CompanyA＆amp;启动Outlook时的CompanyB文件夹。每当移动到包含附件的内容时，它都会将它们保存到您的文件位置并将该电子邮件标记为已读。

我还没有测试过代码 - 而且Outlook文件夹和文件位置需要更新才能满足您的需求。