Outlook 无法对此类附件执行此操作

Question

我正在尝试保存电子邮件中的附件。我收到错误消息

Outlook cannot perform this action on this type of attachment

使用 Debug.Print outAttachment，它正在尝试提取图片（与设备无关的位图）。
我只需要提取 Excel 和 pdf，但如果这意味着代码有效，我不介意提取图片。

Public Sub Extract_Attachments_From_Outlook_Msg_Files()
    
    Dim outApp As Object
    Dim outEmail As Object
    Dim outAttachment As Object
    Dim msgFiles As String, sourceFolder As String, saveInFolder As String
    Dim fileName As String
    Dim FilePath As String
    
    Application.DisplayAlerts = False
           
    msgFiles = Sheets("Instructions").Range("H1") & Sheets("Instructions").Range("H2") & ".msg" 'folder location and filespec of .msg files"
    Debug.Print msgFiles
    saveInFolder = Sheets("Instructions").Range("H1")         'folder where extracted attachments are saved
    Debug.Print saveInFolder
        
    If Right(saveInFolder, 1) <> "\" Then saveInFolder = saveInFolder & "\"
        sourceFolder = Left(msgFiles, InStrRev(msgFiles, "\"))
        Debug.Print sourceFolder
        On Error Resume Next
        Set outApp = GetObject(, "Outlook.Application")
        If outApp Is Nothing Then
            MsgBox "Outlook is not open"
            Exit Sub
        End If
        On Error GoTo 0
        
        fileName = Dir(msgFiles)
        While fileName <> vbNullString
        
        Set outEmail = outApp.Session.OpenSharedItem(sourceFolder & fileName)
            
        For Each outAttachment In outEmail.Attachments
            outAttachment.SaveAsFile saveInFolder & outAttachment.fileName
        Next
        
        fileName = Dir
            
    Wend
        
End Sub

Answer 1

这是嵌入了 OLE 对象的 RTF 格式邮件，对吧？ Outlook 对象模型不允许对这种类型的附件做很多事情 (Attachment.Type == olOLE)。

如果使用Redemption is an option (I am its author), its RDOAttachment.SaveAsFile方法足够智能，可以从存储中提取BMP、EMF、PDF、Excel等文件数据。像下面这样的东西（在我的脑海中）应该可以完成这项工作：

  set Session = CreateObject("Redemption.RDOSession")
  set outEmail= Session.GetMessageFromMsgFile(sourceFolder & fileName)
  For Each outAttachment In outEmail.Attachments
      outAttachment.SaveAsFile saveInFolder & outAttachment.fileName
  Next

Outlook 无法对此类附件执行此操作

Outlook cannot perform this action on this type of attachment

outlook

vba