Outlook - 从带有 .xls 附件的电子邮件和特定发件人中保存文件，然后将电子邮件移动到子文件夹

Posted 2023-03-07

【中文标题】Outlook - 从带有 .xls 附件的电子邮件和特定发件人中保存文件，然后将电子邮件移动到子文件夹

【英文标题】：Outlook - Save file from email with .xls attachment and from specific sender then move email to sub folder

【发布时间】：2013-08-22 14:03:06

【问题描述】：

我想在收件箱中收到来自特定电子邮件地址的带有 .xls 附件的新电子邮件时触发宏。 我尝试在 Outlook 中设置规则，但它没有过滤发件人，也没有附件。

我想做的是：

当新电子邮件进入收件箱时，请检查它是否来自某个电子邮件地址 ag:Myaddress.me.co.uk。如果电子邮件不是来自正确的地址，则什么也不做。 如果主题行包含某些词，例如：“价格检查”。如果主题不匹配，什么也不做。 如果电子邮件来自正确的地址 检查新电子邮件是否有 .xls 附件。如果它没有 .xls 附件，则什么也不做。 将附件保存在文件夹中，例如：“C:\MyFolder” 将电子邮件标记为已读并移至子文件夹，例如：“PriceCheckFolder”

我一直在使用此代码检查收件箱，但它会查看文件夹中的所有电子邮件，我只希望它查看符合条件的第一个实例。

非常感谢梅琳达

‘in thisworkbook

Private WithEvents Items As Outlook.Items

Private Sub Application_Startup()
  Dim olApp As Outlook.Application
  Dim objNS As Outlook.NameSpace
  Dim SubFolder As MAPIFolder

  Set olApp = Outlook.Application
  Set objNS = olApp.GetNamespace("MAPI")
  ' default local Inbox
  Set Items = objNS.GetDefaultFolder(olFolderInbox).Items
End Sub


Private Sub Items_ItemAdd(ByVal item As Object)

  On Error GoTo ErrorHandler

  Dim Msg As Outlook.MailItem

  If TypeName(item) = "MailItem" Then
    Set Msg = item
    Call SaveAttachmentsToFolder
  End If

ProgramExit:
  Exit Sub

ErrorHandler:
  MsgBox Err.Number & " - " & Err.Description
  Resume ProgramExit
End Sub


Sub SaveAttachmentsToFolder()

'Error handling
  On Error GoTo SaveAttachmentsToFolder_err


‘in module1

' Declare variables
  Dim ns As NameSpace
  Dim Inbox As MAPIFolder
  Dim SubFolder As MAPIFolder
  Dim item As Object
  Dim Atmt As Attachment
  Dim FileName As String
  Dim i As Integer
  Dim varResponse As VbMsgBoxResult
  Dim StringLength As Long
  Dim Filename1 As String
  Dim FilenameA As String
  Dim FilenameB As String

'Set the variable values to be used in the code
  Set ns = GetNamespace("MAPI")
  Set Inbox = ns.GetDefaultFolder(olFolderInbox)
  Set SubFolder = Inbox.Folders("Test")
  i = 0

' Check subfolder for messages and exit of none found
  If SubFolder.Items.Count = 0 Then
  ' "Nothing Found"
    Exit Sub
  End If

' Check each message for attachments
  For Each item In SubFolder.Items
    For Each Atmt In item.Attachments
      ' Check filename of each attachment and save if it has "xls" extension
      If Right(Atmt.FileName, 3) = "xls" Then
        StringLength = Len(Atmt.FileName)

        FileName = "\\feltfps0003\gengrpshare0011\Value Team\Melinda_BK\OutlookVBA\TestOutput\" & Left(Atmt.FileName, (StringLength - 13)) & Format(item.CreationTime, "ddmmmyyyy") & ".xls"
        Atmt.SaveAsFile FileName
        i = i + 1
      End If
    Next Atmt
  Next item

' Clear memory
SaveAttachmentsToFolder_exit:
  Set Atmt = Nothing
  Set item = Nothing
  Set ns = Nothing
  Exit Sub

' Handle Errors
SaveAttachmentsToFolder_err:
    MsgBox "An unexpected error has occurred." _
    & vbCrLf & "Please note and report the following information." _
    & vbCrLf & "Macro Name: GetAttachments" _
    & vbCrLf & "Error Number: " & Err.Number _
    & vbCrLf & "Error Description: " & Err.Description _
    , vbCritical, "Error!"sub
Resume SaveAttachmentsToFolder_exit
End Sub

【问题讨论】：

您将要创建一个宏，并通过对每条传入消息的规则运行。您可以很容易地检查发​​件人地址并像您一样遍历附件。

【参考方案1】：

我尝试在 Outlook 中设置规则，但它没有过滤发件人，也没有过滤附件。

创建一个调用以下脚本的规则。

它将在所有收到的邮件上运行，但只为您查找的任何电子邮件地址执行您的代码

Sub checkEmailSenderAndDoStuff(myItem As MailItem)

    'set this up as a script to run on all incoming mail
    Dim myTargetEmailAddress As String
    myTargetEmailAddress = "[e-mail]"

    'this will check if the sender email is whatever sender
    'you want to check from
    If myItem.SenderEmailAddress = myTargetEmailAddress Then
        'do whatever you wanted to do with attachments, moving, etc
    End If
End Sub