Question

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

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

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

Answer 1

您可以处理Application类的ItemSend事件，您可以在其中查看To地址（或收件人集合）并在需要时保存附件。例如：

 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

只要用户通过Inspector（在检查器关闭之前，但在用户单击“发送”按钮之后）或Outlook项目的“发送”方法发送Microsoft Outlook项目时，就会触发ItemSend事件。作为MailItem，用于程序中。

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

Answer 2

在Outlook中创建了3个后续列表和一个规则。

当电子邮件发送到（添加所有帖子列表）并有附件时运行此脚本。 PS。你必须编辑所有路径，foldernames和postlistnames。

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代码，用于根据发送到的电子邮件保存附件

2 个答案: