删除内联附件

Question

我正在尝试搜索选定的电子邮件并删除附件。我做了一些研究，最终选择了 Word.Document 路线。

我之前有一段代码删除了所有附件，但留下了一个虚线框，表示图像不可用。

我正在尝试将两者网格化，因为下面的这个不会删除附件，而只会删除内联形状。

删除内联图像的代码：

Sub DeleteAllAttachmentsFromSelectedMessages()
Dim selectedItems As Selection
Dim messageObject As Object
Dim documentsObject As Object
Dim shp As InlineShape
Dim doc As Object
Dim shpRange As Object
Const wdInlineShapePicture As Long = 3
Const wdInlineShapesEmbeddedOLEObject As Long = 1

' Set reference to the Selection.
Set selectedItems = ActiveExplorer.Selection

For Each messageObject In selectedItems
    Set doc = messageObject.GetInspector.WordEditor
    ' doc.UnProtect
    For Each shp In doc.InlineShapes
        Select Case shp.Type
            Case wdInlineShapePicture, wdInlineShapesEmbeddedOLEObject
                Set shpRange = doc.Range(shp.Range.Characters.First.Start, shp.Range.Characters.Last.End)
                shpeRange.Text = "Attachment Removed" ' Replace shape with text
            Case Else
                ' Other shapes not supported yet
        End Select
    ' doc.Protect
    messageObject.Save
    Next
Next

MsgBox "Attachments were removed.", vbOKOnly, "Message"

Set selectedItems = Nothing
Set messageObject = Nothing
Set documentsObject = Nothing
Set shp = Nothing
Set doc = Nothing
Set shpRange = Nothing
End Sub

对于我用来删除所有附件的代码：

Sub DeleteAllAttachmentsFromSelectedMessages()
Dim attachmentsObject As Attachments
Dim selectedItems As Selection
Dim messageObject As Object
Dim attachmentCount As Long

Set selectedItems = ActiveExplorer.Selection

For Each messageObject In selectedItems
    Set attachmentsObject = messageObject.Attachments

    attachmentCount = attachmentsObject.Count

    While attachmentCount > 0
        attachmentsObject(1).Delete
        attachmentCount = attachmentsObject.Count
    Wend

    messageObject.Save

Next

MsgBox "Attachments were removed.", vbOKOnly, "Message"

Set attachmentsObject = Nothing
Set selectedItems = Nothing
Set messageObject = Nothing
End Sub

Answer 1

多年前，我调查了内联附件。我的回忆是不同的电子邮件包以非常不同的方式处理它们，因此不可能给出明确的指示。

基本问题是您正在删除附件，而不是在电子邮件正文中显示它的命令。

选择其中一些电子邮件并运行下面的宏。它会在桌面上创建一个名为 DemoExplorer,txt 的文件，其中包含电子邮件的选定属性。在 Html 正文中，您会发现如下内容：

<img width=2112 height=1186 style='width:22.0in;height:12.3541in'
     id="Picture_x0020_1" src="cid:image001.jpg@01D22C6F.05449B60">

您必须删除此 IMG 元素才能从 Html 正文中删除图像。

Public Sub DemoExplorer()

  ' Outputs selected properties of selected emails to a file.

  ' Technique for locating desktop from answer by Kyle:
  ' http://stackoverflow.com/a/17551579/973283

  ' Needs reference to Microsoft Scripting Runtime if "TextStream"
  ' and "FileSystemObject" are to be recognised

  ‘ Coded by Tony Dallimore

  Dim AttachCount As Long
  Dim AttachType As Long
  Dim FileOut As TextStream
  Dim Fso As FileSystemObject
  Dim Exp As Outlook.Explorer
  Dim InxA As Long
  Dim ItemCrnt As MailItem
  Dim NumSelected As Long
  Dim Path As String

  Path = CreateObject("WScript.Shell").specialfolders("Desktop")

  Set Fso = CreateObject("Scripting.FileSystemObject")
  Set FileOut = Fso.CreateTextFile(Path & "\DemoExplorer.txt", True)

  Set Exp = Outlook.Application.ActiveExplorer

  NumSelected = Exp.Selection.Count

  If NumSelected = 0 Then
    Debug.Print "No emails selected"
  Else
    For Each ItemCrnt In Exp.Selection
      With ItemCrnt
        FileOut.WriteLine "--------------------------"
        FileOut.WriteLine "From: " & .SenderName
        FileOut.WriteLine "Subject: " & .Subject
        FileOut.WriteLine "Received: " & Format(.ReceivedTime, "dMMMyy h:mm:ss")
        FileOut.WriteLine "Text: " & Replace(Replace(Replace(.Body, vbLf, "{lf}"), vbCr, "{cr}"), vbTab, "{tb}")
        FileOut.WriteLine "Html: " & Replace(Replace(Replace(.HtmlBody, vbLf, "{lf}"), vbCr, "{cr}"), vbTab, "{tb}")
        AttachCount = .Attachments.Count
        FileOut.WriteLine "Number of attachments: " & AttachCount
        For InxA = 1 To AttachCount
          AttachType = .Attachments(InxA).Type
          FileOut.WriteLine "Attachment " & InxA
          FileOut.Write "  Attachment type: "
          Select Case AttachType
            Case olByValue
              FileOut.WriteLine "By value"
            Case olEmbeddeditem
              FileOut.WriteLine "Embedded item"
            Case olByReference
              FileOut.WriteLine "By reference"
            Case olOLE
              FileOut.WriteLine "OLE"
            Case Else
              FileOut.WriteLine "Unknown " & AttachType
          End Select
          ' I recall PathNasme giving an error for some types
          On Error Resume Next
          FileOut.WriteLine "  Path: " & .Attachments(InxA).PathName
          On Error GoTo 0
          FileOut.WriteLine "  File name: " & .Attachments(InxA).FileName
          FileOut.WriteLine "  Display name: " & .Attachments(InxA).DisplayName
          ' I do not recall every seeing a parent but it is listed as a property
          ' but for some attachment types it gives an error
          On Error Resume Next
          FileOut.WriteLine "  Parent: " & .Attachments(InxA).Parent
          On Error GoTo 0
          FileOut.WriteLine "  Position: " & .Attachments(InxA).Position
        Next
      End With
    Next
  End If

  FileOut.Close

End Sub