基于Redemption的Outlook VBA脚本：转移特定发件人的带msg附件邮件

Got it, let's wrap up your script using Redemption—great call picking it for this task, since it lets us inspect attachments without saving them first. Here's a complete, working implementation that covers all your requirements:

Complete Script Code #

' Initialize Redemption session and link to Outlook's MAPI session
Set objRDOSession = CreateObject("Redemption.RDOSession")
objRDOSession.MAPIOBJECT = CreateObject("Outlook.Application").Session.MAPIOBJECT

' --- CONFIGURE THESE VALUES TO MATCH YOUR NEEDS ---
strSpecifiedSender = "sender@example.com" ' Replace with target sender's email address
strTargetFolderName = "Processed MSG Attachments" ' Replace with your target folder name
' --------------------------------------------------

' Get the default Inbox folder
Set objInbox = objRDOSession.GetDefaultFolder(6) ' 6 = olFolderInbox

' Locate or create the target folder under Inbox
On Error Resume Next
Set objTargetFolder = objInbox.Folders(strTargetFolderName)
If Err.Number <> 0 Then
    Set objTargetFolder = objInbox.Folders.Add(strTargetFolderName)
End If
On Error GoTo 0

' Loop through all items in the Inbox
For Each objItem In objInbox.Items
    ' Only process actual email messages
    If objItem.Class = 43 Then ' 43 = olMail
        Set objMail = objItem
        
        ' Check if the email has attachments
        If objMail.Attachments.Count > 0 Then
            Dim hasValidMsgAttachment
            hasValidMsgAttachment = False
            
            ' Check each attachment for MSG file
            For Each objAttachment In objMail.Attachments
                ' Validate by file extension AND attachment type (covers edge cases)
                If LCase(Right(objAttachment.FileName, 4)) = ".msg" Or objAttachment.Type = 5 Then ' 5 = olEmbeddeditem (common for MSG attachments)
                    hasValidMsgAttachment = True
                    Exit For ' No need to check other attachments once found
                End If
            Next
            
            ' If valid MSG exists AND sender matches, move the email
            If hasValidMsgAttachment Then
                ' Use SenderEmailAddress for exact match (case-insensitive)
                If LCase(objMail.SenderEmailAddress) = LCase(strSpecifiedSender) Then
                    objMail.MoveTo objTargetFolder
                    WScript.Echo "Moved email: " & objMail.Subject
                End If
            End If
        End If
    End If
Next

' Clean up objects
Set objAttachment = Nothing
Set objMail = Nothing
Set objTargetFolder = Nothing
Set objInbox = Nothing
Set objRDOSession = Nothing
WScript.Echo "Processing complete!"

Key Details & Explanations #

• Redemption Integration: We link Redemption to Outlook's existing MAPI session to bypass security prompts and unlock its attachment-inspecting capabilities without saving files.
• Folder Management: The script automatically creates your target folder if it doesn't exist under the Inbox—adjust the folder path if you need it elsewhere (e.g., a top-level Outlook folder).
• Attachment Validation: We check both the file extension (.msg) and Redemption's attachment type (olEmbeddeditem) to catch all MSG attachments, even if the filename doesn't show the extension.
• Sender Matching: Using SenderEmailAddress ensures an exact, case-insensitive match. If you prefer to match by display name, swap that line with LCase(objMail.SenderName) = LCase(strSpecifiedSender).
• Error Handling: Basic error handling for folder creation prevents crashes if the folder already exists or permissions are restricted.

Merging with Your Existing Code #

If you already have a partial script running, you can drop in these critical sections:

• The dual-check for MSG attachments using Redemption's RDOAttachment properties
• The sender validation logic
• The MoveTo method to relocate qualifying emails to your target folder

内容的提问来源于stack exchange，提问作者Plisken