如何自动保存来自特定发件人的附件？

Question

我想自动将来自特定发件人的附件保存在预定文件夹中。

Public WithEvents objInboxItems As Outlook.Items

Private Sub Application_Startup()
   Set objInboxItems = Session.GetDefaultFolder(olFolderInbox).Items
End Sub

Private Sub objInboxItems_ItemAdd(ByVal Item As Object)
   Dim objMail As Outlook.MailItem
   Dim strSenderAddress As String
   Dim strSenderDomain As String
   Dim objAttachment As Attachment
   Dim strFolderPath As String
   Dim strFileName As String

   If Item.Class = olMail Then
      Set objMail = Item

      'Get sender domain
      strSenderAddress = objMail.SenderEmailAddress
      'strSenderDomain = Right(strSenderAddress, Len(strSenderAddress) - InStr(strSenderAddress, "@"))

      'Change to the specific domain as per your needs
      If strSenderAddress = "Da.Te@union.de" Then
         If objMail.Attachments.Count > 0 Then
            For Each objAttachment In objMail.Attachments
                'Change the folder path where you want to save attachments
                strFolderPath = "U:\Test"
                strFileName = objMail.Subject & " " & Chr(45) & " " & objAttachment.FileName
                objAttachment.SaveAsFile strFolderPath & strFileName
            Next
         End If
      End If
   End If
End Sub

这段代码来自这里，稍作修改。

Answer 1

下面怎么样...记得重启Outlook

Private WithEvents Items As Outlook.Items
Private Sub Application_Startup()
    Dim olNs As Outlook.NameSpace
    Dim Inbox  As Outlook.MAPIFolder

    Set olNs = Application.GetNamespace("MAPI")
    Set Inbox = olNs.GetDefaultFolder(olFolderInbox)

    Dim Filter As String
        Filter = "@SQL=" & Chr(34) & "urn:schemas:httpmail:fromemail" & _
                           Chr(34) & " Like '%Da.Te@union.de%' And " & _
                           Chr(34) & "urn:schemas:httpmail:hasattachment" & _
                           Chr(34) & "=1"

    Set Items = Inbox.Items.Restrict(Filter)
End Sub



Private Sub Items_ItemAdd(ByVal Item As Object)
    If TypeOf Item Is Outlook.MailItem Then

        Dim FilePath As String
            FilePath = "C:\Temp\"

        Dim AtmtName As String
        Dim Atmt As attachment

        For Each Atmt In Item.Attachments
            AtmtName = FilePath & Atmt.filename
            Atmt.SaveAsFile AtmtName
        Next
    End If
End Sub

_{Items.ItemAdd 事件 (Outlook)在将一项或多项添加到指定集合时发生。 当大量项目一次添加到文件夹时，此事件不会运行。 此事件在 Microsoft Visual Basic Sc​​ripting Edition (VBScript) 中不可用。}

---

_{Items.Restrict 方法是使用 Find 方法或 FindNext 方法迭代集合中特定项目的替代方法。 如果项目数量较少，则 Find 或 FindNext 方法比过滤更快。 如果集合中有大量项目，则 Restrict 方法要快得多，尤其是当预计只能找到大型集合中的少数项目时。}

---

_{使用DASL 过滤器支持的字符串比较过滤项目包括等价、前缀、短语和子字符串匹配。 请注意，在对 Subject 属性进行筛选时，将忽略诸如“RE:”和“FW:”之类的前缀。}

Answer 2

我认为您发布的代码没有任何问题，我也希望使用该代码，但不是按域过滤，而是按特定发件人过滤。 我根据自己的需要稍微调整了代码，并通过将需要修改的 3 个字段移到顶部，使新用户的调整更容易。 我还注释掉了保存以“主题 - 附件名称”为前缀的附件的部分，因此它纯粹将其保存为“附件名称”。

我的问题是我没有在信任中心启用宏，我在一个单独的模块中使用它，但它必须在“ThisOutlookSession”下。

我还添加了一行以在保存附件后删除消息。

Public WithEvents objInboxItems As Outlook.Items

Private Sub Application_Startup()
   Set objInboxItems = Session.GetDefaultFolder(olFolderInbox).Items
End Sub

Private Sub objInboxItems_ItemAdd(ByVal Item As Object)
   Dim objMail As Outlook.MailItem
   Dim strSenderAddress As String
   Dim strSenderDomain As String
   Dim objAttachment As Attachment
   Dim strFolderPath As String
   Dim strFileName As String
   Dim strDesiredSender As String
   Dim strDesiredDomain As String

   strFolderPath = Environ("USERPROFILE") & "\Documents\"
   'strDesiredDomain = "gmail.com"
   strDesiredSender = "user@gmail.com"

   If Item.Class = olMail Then
      Set objMail = Item

      'Get sender domain
      strSenderAddress = objMail.SenderEmailAddress
      strSenderDomain = Right(strSenderAddress, Len(strSenderAddress) - InStr(strSenderAddress, "@"))

      'Use either strSenderDomain or strSenderAddress Depending on Filter Desired
      'If strSenderDomain = strDesiredDomain Then
      If strSenderAddress = strDesiredSender Then
         If objMail.Attachments.Count > 0 Then
            For Each objAttachment In objMail.Attachments
                ''''Save in format "Subject - Attachmentname"
                'strFileName = objMail.Subject & " " & Chr(45) & " " & objAttachment.FileName
                'objAttachment.SaveAsFile strFolderPath & strFileName 
                ''''Save in format exactly as attachment name
                objAttachment.SaveAsFile strFolderPath & objAttachment.FileName 
                objMail.Delete 'Delete after saving attachment
            Next
         End If
      End If
   End If
End Sub