展望 - 使用.xls附件和特定發件人從電子郵件保存文件，然後將電子郵件移動到子文件夾

Question

我希望在收件箱中收到來自特定電子郵件地址且帶有.xls附件的新電子郵件時觸發宏。 我試圖在Outlook中設置規則，但它不會過濾發件人，也不會過濾附件。

我想這樣做的是以下幾點：

1. 當有新郵件進入收件箱檢查它是否是從某個電子郵件地址AG：Myaddress.me.co.uk。如果電子郵件不是來自正確的地址，則什麼也不做。
2. 如果主題行包含某些詞語，例如：「價格檢查」。它的主題不匹配什麼都不做。
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