Outlook VBA 用文本替换内联对象

Question

我的收件箱中有一封包含内联对象（例如图像）的电子邮件。我想删除它，然后在电子邮件的同一位置插入文本。

我尝试了两种方法：

1. 使用Dim objAttachment As Outlook.Attachment 处理对象。我尝试使用Position 方法，但问题是它总是返回0，不管对象的位置（以及它是内联还是在“附件栏”中）。

2. 使用Dim shp As Word.InlineShape 处理对象。我可以使用Set shpRange = objDoc.Range(shp.Range.Characters.First.Start, shp.Range.Characters.Last.End)（和Dim objDoc As Word.Document；感谢an answer below）确定shp 的位置。我尝试通过三种方式修改objDoc。

   2.1。 shpRange.InsertAfter "Replacement Text 1".

   2.2。 shpRange.Text = "Replacement Text 2".

   2.3。 objDoc.Characters(1).InsertBefore "New Text".

   问题是他们都没有修改邮件。

到目前为止，我已将方法 1 用于objMsg.HTMLBody = <mytext> + objMsg.HTMLBody，然后是objMsg.Save。但这会在开头添加文本。

PS：当一个人用内联对象回复电子邮件时，它有时会被对象所在位置的文本替换（我无法确定何时完成）。也许 MS 没有提供实现相同功能的功能。

---

编辑（额外的细节，为了避免 tl;dr 最初不包括在内）

注意事项：

1. 我目前使用的代码是基于a post by Nicola Delfino。它使用objMsg.HTMLBody，见下文。 从好的方面来说，它可以找到大多数内联附件/对象（有些被遗漏），并且都在“附件栏”中（我不知道它的正式名称）。 不利的一面是，它无法区分 inline 和“bar-attach”项目，也无法获取找到的 inline 对象的位置。所以我让它只在邮件正文的开头添加文本。

2. 我发现我尝试过的任何电子邮件都有问题。例如，我创建了一封电子邮件，并插入了一张带有Insert -> Picture 的图片。发送电子邮件后，我处理了Sent Items 文件夹中的电子邮件。

3. 我附上了我用于测试的示例电子邮件的图像。

4. 在阅读this official page for Outlook 2007 之后，objMsg.HTMLBody 可能永远无法工作，我应该选择WordEditor： "17.5 使用 WordEditor Outlook 对象模型本身没有提供确定光标在项目正文中的位置的直接方法。但是，由于每个项目正文的编辑器（“便笺”和分发列表除外）都是 Microsoft Word 的特殊版本，因此您不仅可以使用 Word 技术在插入点添加文本，还可以在任何地方添加格式化文本在项目中，甚至添加图片。”

5. 可能相关的链接：

How do I get the selected text from a WordEditor Object and change it's color?

Deletion of InlineShape does not work for RTF mails

我的代码：

    Public Sub StripAttachments()
        'Put in the folder location you want to save attachments to
        Dim strFolder As String
        strFolder = "removed_attachments"
        Dim ilocation As String
        ilocation = GetSpecialFolder(&H5) & "\" & strFolder ' CSIDL_MY_DOCUMENTS As Long = &H5"
        On Error Resume Next
        ilocation = ilocation & "\"

        ' Instantiate an Outlook Application object.
        Dim objOL As Outlook.Application
        Set objOL = Application
        ' Get the collection of selected objects.
        Dim objSelection As Outlook.Selection
        Set objSelection = objOL.ActiveExplorer.Selection

        'Dim objMsg As Object
        Dim objMsg As Outlook.MailItem
        ' Check each selected item for attachments. If attachments exist, save them to the selected
        ' folder and strip them from the item.
        For Each objMsg In objSelection
            ' This code only strips attachments from mail items.
            If (objMsg.Class = olMail) Then
                Dim objInsp As Outlook.Inspector
                Set objInsp = objMsg.GetInspector
            Dim objDoc As Word.Document
            Set objDoc = objInsp.WordEditor

                ' Get the Attachments collection of the item.
                Dim objAttachments As Outlook.attachments
                Set objAttachments = objMsg.attachments
                Dim lngCount As Long
                lngCount = objAttachments.Count
                If lngCount > 0 Then
                    ' We need to use a count down loop for removing items from a collection. Otherwise,
                    ' the loop counter gets confused and only every other item is removed.
                    Dim strFile As String
                    strFile = ""

                    Dim I As Long
                    For I = lngCount To 1 Step -1
                        ' Save attachment before deleting from item.
                        ' Get the file name.
                        Dim objAttachment As Outlook.Attachment
                        Set objAttachment = objAttachments.item(I)

                        Dim strHTML As String
                        strHTML = "<li><a href=" & Chr(34) & "file:" & ilocation & objAttachment.FileName & Chr(34) _
                          & ">" & objAttachment.FileName & "</a><br>" & vbCrLf
                        strFile = strFile & strHTML

                        Dim attPos As Long
                        attPos = objAttachment.Position
                        ' Save the attachment as a file
                        objAttachment.SaveAsFile (ilocation & objAttachments.item(I))
                        ' Remove the attachment
                        objAttachment.Delete
                        ' Replace with text and hyperlink
                        'strFile = "Attachments removed from the message and backed up to [<a href='" & ilocation & "'>" & ilocation & "</a>]:<br><ul>" & strFile & "</ul><hr><br><br>" & vbCrLf & vbCrLf
                    Next I

                    strFile = "Attachments removed from the message and backed up to [<a href='" & ilocation & "'>" & ilocation & "</a>]:<br><ul>" & strFile & "</ul><hr><br><br>" & vbCrLf & vbCrLf
                    objDoc.Characters(1).InsertBefore strFile  ' Does nothing!
                    objMsg.HTMLBody = strFile + objMsg.HTMLBody
                    objMsg.Save
                Else
                    msgbox ("No attachments were found in the selected email")
                End If
            Else
                msgbox ("Selection is not of type olMail")
            End If
        Next

    ExitSub:
        Set objAttachments = Nothing
        Set objMsg = Nothing
        Set objSelection = Nothing
        Set objOL = Nothing
    End Sub

Answer 1

如果我没记错的话，WordEditor 基本上是一个词 Document，所以你应该能够做类似的事情（在 Word 中测试，可能需要针对 Outlook 进行调整），假设像 doc 这样的对象变量代表Document：

在 Outlook 2010 中进行了修订和测试

Dim shp as InlineShape
Dim doc as Object `Word.Document
Dim shpRange as Object `Word.Range
Const wdInlineShapePicture as Long = 3
Const wdInlineShapesEmbeddedOLEObject as Long = 1
Set doc = objMsg.GetInspector.WordEditor
For Each shp In doc.InlineShapes
    Select Case shp.Type 
        Case wdInlineShapePicture, wdInlineShapesEmbeddedOLEObject
            '## Assign a range object with the text position of the shape
            Set shpRange = doc.Range(shp.Range.Characters.First.Start, _
                                  shp.Range.Characters.Last.End)
            '## Replace the shape with text:
            shpRange.Text = "Replacement Text"
        Case Else
            '## Do something else for other shape types, etc.
      End Select

Next

这是一个示例宏，用于处理传入的邮件，并用文本替换嵌入的图像。注意需要UnProtect文档：

Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
    Dim arr() As String
    Dim i As Integer
    Dim m As MailItem
    '## Word objects, using late-binding (or enable reference to MS Word)
    Dim shp As Object 'Word.InlineShape
    Dim doc As Object 'Word.Document
    Dim shpRange As Object 'Word.Range
    '## Establish some word constants for use with late-binding
    Const wdInlineShapePicture As Long = 3
    Const wdInlineShapeEmbeddedOLEObject As Long = 1
    Const wdInlineShapeLinkedPicture As Long = 4

    arr = Split(EntryIDCollection, ",")
    For i = 0 To UBound(arr)
        Set m = Application.Session.GetItemFromID(arr(i))
        Set doc = m.GetInspector.WordEditor
        doc.UnProtect
        For Each shp In doc.InlineShapes
            Select Case shp.Type
                Case wdInlineShapePicture, _
                     wdInlineShapeEmbeddedOLEObject, _
                     wdInlineShapeLinkedPicture

                    '## Assign a range object with the text position of the shape
                    Set shpRange = doc.Range(shp.Range.Characters.First.Start, _
                                              shp.Range.Characters.Last.End)
                    '## Replace the shape with text:
                    shpRange.Text = "Replacement Text"
                Case Else

            End Select
        Next
    Next
End Sub