仅限于转发的、来自特定发件人的邮件以及下载附件

Question

我找到了检索附件的代码：https://www.rondebruin.nl/win/s1/outlook/saveatt.htm

我对其进行了改进，将发件人信息作为可选过滤输入考虑在内：

Sub SaveEmailAttachmentsToFolder(OutlookFolderInInbox As String, _
  ExtString As String, DestFolder As String, _
  Optional Filter As String = "[SenderEmailAddress] = 's@example.com'")
                                 
    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 MyDocPath As String
    Dim I As Integer
    Dim wsh As Object
    Dim fs As Object
    
    On Error GoTo ThisMacro_err

    Set ns = GetNamespace("MAPI")
    Set Inbox = ns.GetDefaultFolder(olFolderInbox)
    Set SubFolder = Inbox.Folders(OutlookFolderInInbox)

    I = 0
    ' Check subfolder for messages and exit of none found
    If SubFolder.Items.Count = 0 Then
        MsgBox "There are no messages in this folder : " & OutlookFolderInInbox, _
               vbInformation, "Nothing Found"
        Set SubFolder = Nothing
        Set Inbox = Nothing
        Set ns = Nothing
        Exit Sub
    End If

    'Create DestFolder if DestFolder = ""
    If DestFolder = "" Then
        Set wsh = CreateObject("WScript.Shell")
        Set fs = CreateObject("Scripting.FileSystemObject")
        MyDocPath = wsh.SpecialFolders.Item("mydocuments")
        DestFolder = MyDocPath & "\" & Format(Now, "dd-mmm-yyyy hh-mm-ss")
        If Not fs.FolderExists(DestFolder) Then
            fs.CreateFolder DestFolder
        End If
    End If

    If Right(DestFolder, 1) <> "\" Then
        DestFolder = DestFolder & "\"
    End If

    ' Check each message for attachments and extensions
    For Each Item In SubFolder.Items.Restrict(Filter)
        For Each Atmt In Item.Attachments
            If LCase(Right(Atmt.FileName, Len(ExtString))) = LCase(ExtString) Then
                FileName = DestFolder & Item.SenderName & " " & Atmt.FileName
                Atmt.SaveAsFile FileName
                I = I + 1
            End If
        Next Atmt
    Next Item

    ' Show this message when Finished
    If I > 0 Then
        MsgBox "You can find the files here : " _
             & DestFolder, vbInformation, "Finished!"
    Else
        MsgBox "No attached files in your mail.", vbInformation, "Finished!"
    End If

    ' Clear memory
ThisMacro_exit:
    Set SubFolder = Nothing
    Set Inbox = Nothing
    Set ns = Nothing
    Set fs = Nothing
    Set wsh = Nothing
    Exit Sub

    ' Error information
ThisMacro_err:
    MsgBox "An unexpected error has occurred." _
         & vbCrLf & "Please note and report the following information." _
         & vbCrLf & "Macro Name: SaveEmailAttachmentsToFolder" _
         & vbCrLf & "Error Number: " & Err.Number _
         & vbCrLf & "Error Description: " & Err.Description _
         , vbCritical, "Error!"
    Resume ThisMacro_exit

End Sub

我想进一步完善它，将邮件从 s@example.com 发送到其他人。

有没有办法检查邮件是否发送到 s@example.com 然后转发给我？如果可以，我可以获取发送原始邮件的人的电子邮件地址吗？
我只想下载最初由某些电子邮件地址发送的附件。

另一种解释方式：

1. A1、A2、A3、A4...向 B 发送邮件。B 将这些邮件转发给我
2. B 给我发的邮件不是来自其他人的邮件
3. 如果是B转发的，检查原发件人
4. 如果发件人在我输入的发件人数组（例如 A1、A4）中，请下载附件

Answer 1

所以我在 cmets 的帮助下重新编写了代码。

它不是很优化，但现在仍然满足我的需求：

Public Function InString(ss As String, s As String, Optional Case_Sensitive As Boolean = True) As Boolean

    'This function returns True/False if substring found in string
    Application.ScreenUpdating = False
    If Case_Sensitive = False Then
        s = UCase(s)
        ss = UCase(ss)
    End If
    InString = InStr(s, ss)
    If (InString = 0) Then
        InString = False
    Else
        InString = True
    End If
    Application.ScreenUpdating = True
    
End Function

Sub SaveEmailAttachmentsToFolder(OutlookFolderInInbox As String, ExtString As String, DestFolder As String, _
                                    Optional prefix_subject As String = "TR:", _
                                    Optional osender As Variant = "something@example.com", _
                                    Optional Filter As String = "[SenderEmailAddress] = ''")
                                 
    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 MyDocPath As String
    Dim I As Integer
    Dim wsh As Object
    Dim fs As Object
    Dim e As Variant
    Dim nfound As Boolean
    
    On Error GoTo ThisMacro_err
    
    Set ns = GetNamespace("MAPI")
    Set Inbox = ns.GetDefaultFolder(olFolderInbox)
    Set SubFolder = Inbox.Folders(OutlookFolderInInbox)
    
    I = 0
    ' Check subfolder for messages and exit of none found
    If SubFolder.Items.Count = 0 Then
        MsgBox "There are no messages in this folder : " & OutlookFolderInInbox, _
               vbInformation, "Nothing Found"
        Set SubFolder = Nothing
        Set Inbox = Nothing
        Set ns = Nothing
        Exit Sub
    End If

    'Create DestFolder if DestFolder = ""
    If DestFolder = "" Then
        Set wsh = CreateObject("WScript.Shell")
        Set fs = CreateObject("Scripting.FileSystemObject")
        MyDocPath = wsh.SpecialFolders.Item("mydocuments")
        DestFolder = MyDocPath & "\" & Format(Now, "dd-mmm-yyyy hh-mm-ss")
        If Not fs.FolderExists(DestFolder) Then
            fs.CreateFolder DestFolder
        End If
    End If

    If Right(DestFolder, 1) <> "\" Then
        DestFolder = DestFolder & "\"
    End If

    ' Check each message for attachments and extensions
    For Each Item In SubFolder.Items.Restrict(Filter)
        If Len(prefix_subject) > 0 Then
            If Left(Item.Subject, Len(prefix_subject)) = prefix_subject Then
                If Not IsMissing(osender) Then
                    If Not IsArray(osender) Then
                        If InString(CStr(osender), Item.Body, False) Then
                        
                            For Each Atmt In Item.Attachments
                                If LCase(Right(Atmt.FileName, Len(ExtString))) = LCase(ExtString) Then
                                    FileName = DestFolder & Item.SenderName & " " & Atmt.FileName
                                    Atmt.SaveAsFile FileName
                                    I = I + 1
                                End If
                            Next Atmt
                        
                        End If
                    Else

                        nfound = True
                        For Each e In osender
                            If nfound Then
                                If InString(CStr(e), Item.Body, False) Then
                                    For Each Atmt In Item.Attachments
                                        If LCase(Right(Atmt.FileName, Len(ExtString))) = LCase(ExtString) Then
                                            FileName = DestFolder & Item.SenderName & " " & Atmt.FileName
                                            Atmt.SaveAsFile FileName
                                            I = I + 1
                                        End If
                                    Next Atmt
                                    nfound = False
                                End If
                            End If
                        Next e
                    
                    End If
                Else
                    
                    For Each Atmt In Item.Attachments
                        If LCase(Right(Atmt.FileName, Len(ExtString))) = LCase(ExtString) Then
                            FileName = DestFolder & Item.SenderName & " " & Atmt.FileName
                            Atmt.SaveAsFile FileName
                            I = I + 1
                        End If
                    Next Atmt
                   
                End If
                    
            End If
        Else
            For Each Atmt In Item.Attachments
                If LCase(Right(Atmt.FileName, Len(ExtString))) = LCase(ExtString) Then
                    FileName = DestFolder & Item.SenderName & " " & Atmt.FileName
                    Atmt.SaveAsFile FileName
                    I = I + 1
                End If
            Next Atmt
        End If

    Next Item

    ' Show this message when Finished
    If I > 0 Then
        MsgBox "You can find the files here : " _
             & DestFolder, vbInformation, "Finished!"
    Else
        MsgBox "No attached files in your mail.", vbInformation, "Finished!"
    End If
    
    ' Clear memory
ThisMacro_exit:
    Set SubFolder = Nothing
    Set Inbox = Nothing
    Set ns = Nothing
    Set fs = Nothing
    Set wsh = Nothing
    Exit Sub

    ' Error information
ThisMacro_err:
    MsgBox "An unexpected error has occurred." _
         & vbCrLf & "Please note and report the following information." _
         & vbCrLf & "Macro Name: SaveEmailAttachmentsToFolder" _
         & vbCrLf & "Error Number: " & Err.Number _
         & vbCrLf & "Error Description: " & Err.Description _
         , vbCritical, "Error!"
    Resume ThisMacro_exit

End Sub