根据发送到的电子邮件保存附件的 Outlook 2013 代码

Question

我需要根据发送到的电子邮件（而不是发件人）自动保存附件。

我在邮件服务器上有 3 封电子邮件 pdf@、xml@、txt@。如果电子邮件发送到@pdf，我需要将其保存在网络驱动器上，其他电子邮件也是如此，但要保存到不同的位置。

我看到的所有其他代码只考虑发件人而不是发送地址。

Answer 1

您可以处理应用程序 class 的 ItemSend 事件，您可以在其中签出收件人地址（或收件人集合）并在需要时保存附件。例如：

 Public WithEvents myOlApp As Outlook.Application  

 Public Sub Initialize_handler()  
   Set myOlApp = Outlook.Application  
 End Sub 

 Private Sub myOlApp_ItemSend(ByVal Item As Object, Cancel As Boolean) 
   Dim prompt As String  
   prompt = "Are you sure you want to send " & Item.Subject & "?"  
   If MsgBox(prompt, vbYesNo + vbQuestion, "Sample") = vbNo Then  
     Cancel = True  
   End If  
 End Sub

每当发送 Microsoft Outlook 项目时都会触发 ItemSend 事件，无论是用户通过检查器（在检查器关闭之前，但在用户单击“发送”按钮之后），还是当 Outlook 项目的发送方法时，例如MailItem，在程序中使用。

您可能会发现 Getting Started with VBA in Outlook 2010 文章有帮助。

Answer 2

在 Outlook 中创建了 3 个帖子列表和一个规则。

当电子邮件发送到（添加所有帖子列表）并且有附件时运行这个脚本。 ps。您必须编辑所有路径、文件夹名称和帖子列表名称。

Sub SaveAllAttachments(objitem As MailItem)

Dim objAttachments As Outlook.Attachments
Dim strName, strLocation As String
Dim dblCount, dblLoop As Double

Dim strSub As String
Dim iRcpCount, iRcp As Integer

strLocation = "O:\PDF\"

 On Error GoTo ExitSub
 If objitem.Class = olMail Then
     Set objAttachments = objitem.Attachments
     dblCount = objAttachments.Count
     If dblCount <= 0 Then
         GoTo 100
     End If

    strSub = ""
    iRcpCount = objitem.Recipients.Count
    For iRcp = 1 To iRcpCount
        If objitem.Recipients(iRcp).Name = "Postlist1" Then
            strSub = "Folder1onOdrive"
        ElseIf objitem.Recipients(iRcp).Name = "Postlist2" Then
            strSub = "Folder2onOdrive"
        ElseIf objitem.Recipients(iRcp).Name = "Postlist3" Then
            strSub = "Folder3onOdrive"
        End If

    Next iRcp

    For dblLoop = 1 To dblCount
        strName = objAttachments.Item(dblLoop).FileName
        'strName = strLocation & strName
        strName = strLocation & strSub & strName
        'strName = strLocation & strName
        objAttachments.Item(dblLoop).SaveAsFile strName
    Next dblLoop
    objitem.Delete
End If
100
ExitSub:
Set objAttachments = Nothing
Set objOutlook = Nothing
End Sub

根据发送到的电子邮件保存附件的 Outlook 2013 代码

Outlook 2013 code that saves attachments depending on what email it was sent to

email

outlook

vba