Outlook-從帶有.xls附件的電子郵件和特定發件人中保存文件，然后將電子郵件移至子文件夾

Question

我想在收件箱中收到來自具有.xls附件的特定電子郵件地址的新電子郵件時觸發宏。 我試圖在Outlook中設置一個規則，但它不會對發件人進行過濾，也不會具有附件。

我想做的是以下幾點：

1. 當新電子郵件進入收件箱時，檢查它是否來自某個電子郵件地址ag：Myaddress.me.co.uk。 如果電子郵件不是來自正確的地址，則什么也不做。
2. 如果主題行中包含某些單詞，例如：“ Price Checks”。 如果主題不匹配，則不執行任何操作。
3. 如果電子郵件來自正確的地址，請檢查新電子郵件是否帶有.xls附件。 如果沒有.xls附件，則不執行任何操作。
4. 將附件保存在文件夾中，例如：“ C：\\ MyFolder”
5. 將電子郵件標記為已讀，然后移到子文件夾，例如：“ 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

Answer 1

我試圖在Outlook中設置一個規則，但它不會對發件人進行過濾，也不會具有附件。

創建一個調用以下腳本的規則。

它將在所有傳入的郵件上運行，但僅針對您要查找的任何電子郵件地址執行代碼

Sub checkEmailSenderAndDoStuff(myItem As MailItem)

    'set this up as a script to run on all incoming mail
    Dim myTargetEmailAddress As String
    myTargetEmailAddress = "whatever@wherever.com"

    '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