如何识别拖动的Outlook邮件对象中的指定附件？

我有一个带有MSComctlLib.TreeView控件的userform（用户窗体），用于将拖动到其上的文件保存到磁盘。问题在于，当邮件包含多个附件且拖动其中一个时，无法明确判断选中的是哪一个附件。

当前代码会在文件拖动到TreeView时触发事件，根据DataObject格式调用对应子程序。拖动附件时，代码会解析当前选中邮件中的所有附件（已过滤嵌入图片），但attachments的顺序不会随选中的附件变化，且未找到可用的PropertyAccessor属性来区分选中项。

现有代码如下：

Private Sub treeView_OLEDragDrop(Data As MSComctlLib.DataObject, Effect As Long, Button As Integer, Shift As Integer, x As Single, y As Single)
    Select Case True
        Case Data.GetFormat(13): 'process Email
        Case Data.GetFormat(15): 'process files
        Case Else: processAttachments
    End Select
End Sub

Private Sub processAttachments()
    Dim outlookApp As Object: Set outlookApp = CreateObject("Outlook.Application")
    Dim selection As Object: Set selection = outlookApp.activeexplorer.selection
    Dim email As Object
    Dim attachment As Object
    For Each email In selection
        For Each attachment In email.Attachments
            If Not attachment.PropertyAccessor. _
                GetProperty("http://schemas.microsoft.com/mapi/proptag/0x37140003") = 4 _
                                        Then ' filters out embedded images
                Debug.Print attachment.DisplayName
            End If
        Next
    Next
End Sub

请问是否有方法判断当前选中或正在拖动的是邮件中的哪一个附件？

方法1：直接读取选中的附件对象 #

Outlook的ActiveExplorer.Selection支持直接选中单个或多个附件，无需遍历邮件的所有附件。你可以通过判断选中项的类型来定位目标附件：

Private Sub processAttachments()
    Dim outlookApp As Object: Set outlookApp = CreateObject("Outlook.Application")
    Dim selItem As Object
    
    For Each selItem In outlookApp.ActiveExplorer.Selection
        ' 判断选中项是否为附件
        If TypeName(selItem) = "Attachment" Then
            ' 过滤嵌入图片
            If Not selItem.PropertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x37140003") = 4 Then
                Debug.Print "选中的附件：" & selItem.DisplayName
                ' 在此添加保存附件的逻辑
            End If
        End If
    Next
End Sub

方法2：解析拖动的临时文件路径匹配附件 #

当拖动附件时，Outlook会将附件临时复制到系统临时目录，你可以从DataObject中提取临时文件路径，再通过文件名匹配邮件中的对应附件：

Private Sub treeView_OLEDragDrop(Data As MSComctlLib.DataObject, Effect As Long, Button As Integer, Shift As Integer, x As Single, y As Single)
    Select Case True
        Case Data.GetFormat(13): 'process Email
        Case Data.GetFormat(15): 
            ' 提取拖动的临时文件路径
            Dim filePaths As Variant
            filePaths = Data.GetData(15)
            Dim filePath As String
            For Each filePath In filePaths
                Dim targetFileName As String
                targetFileName = Mid(filePath, InStrRev(filePath, "\") + 1)
                ' 匹配对应的邮件附件
                MatchAttachmentByName targetFileName
            Next
        Case Else: processAttachments
    End Select
End Sub

Private Sub MatchAttachmentByName(targetName As String)
    Dim outlookApp As Object: Set outlookApp = CreateObject("Outlook.Application")
    Dim email As Object
    Dim attachment As Object
    
    For Each email In outlookApp.ActiveExplorer.Selection
        If TypeName(email) = "MailItem" Then
            For Each attachment In email.Attachments
                If Not attachment.PropertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x37140003") = 4 Then
                    If attachment.DisplayName = targetName Then
                        Debug.Print "匹配到的附件：" & attachment.DisplayName
                        ' 执行保存操作
                        Exit For
                    End If
                End If
            Next
        End If
    Next
End Sub

注意事项 #

• 方法1仅适用于先选中附件再拖动的场景；若直接从邮件内拖动未选中的附件，Selection不会包含该附件。
• 方法2通过文件名匹配可能存在重名风险，如需更精确匹配，可结合附件的大小、修改时间等属性交叉验证。

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