Question

我喜欢创建一个Outlook宏，该宏将来自特定发件人的附件自动保存到预定的文件夹中。

当前我正在使用此代码，但是它不起作用：

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

高度赞赏您能提供的任何帮助！

此代码最初来自here，并进行了少量修改。

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 Event (Outlook) 在将一个或多个项目添加到指定的集合时发生。一次将大量项目添加到文件夹时，此事件不会运行。此事件在Microsoft Visual Basic脚本版（VBScript）中不可用。}

_{Items.Restrict method 是使用Find方法或FindNext方法遍历集合中特定项目的替代方法。如果项目数量很少，则Find或FindNext方法比筛选更快。如果集合中有很多项目，则Restrict方法的速度会大大提高，尤其是在大型集合中只有少数项目被发现的情况下。}

DASL过滤器支持的
_{Filtering Items Using a String Comparison 包括对等，前缀，短语和子字符串匹配。请注意，当您对Subject属性进行过滤时，诸如“ RE：”和“ FW：”之类的前缀将被忽略。}

Answer 2

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

我的问题是我没有在信任中心启用宏，而是在单独的模块中启用了宏，但是它必须位于“ 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

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

2 个答案: