Outlook VBA Replace inline object with text

Question

I have an email message in my Inbox which contains an inline object (e.g., an image). I want to remove it, and insert text at the same point in the email.

I tried with two methods:

1. Dealing with objects with Dim objAttachment As Outlook.Attachment. I tried using the Position method, but the problem is that it always returns 0, regardless of the position of the object (and whether it is inline or in the "attachments bar").

2. Dealing with objects with Dim shp As Word.InlineShape. I could determine the location of shp, with Set shpRange = objDoc.Range(shp.Range.Characters.First.Start, shp.Range.Characters.Last.End) (and Dim objDoc As Word.Document; thanks to an answer below). I tried modifying objDoc in three ways.

   2.1. shpRange.InsertAfter "Replacement Text 1".

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

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

   The problem is that none of them modifies the email.

So far, I have used method 1 with objMsg.HTMLBody = <mytext> + objMsg.HTMLBody, then objMsg.Save. But this adds text at the beginning.

PS: when one replies to an email with an inline object, it is sometimes replaced with text at the location of the object (I could not ascertain when this is done). Perhaps MS does not provide functionality for accomplishing the same.

---

EDIT (Extra details, originally not included to avoid tl;dr)

Notes:

1. The code I am currently using is based on a post by Nicola Delfino. It uses objMsg.HTMLBody, see below. On the up side, it finds most inline attachments/objects (some are missed), and all in the "attachments bar" (I do not know the official name for it). On the down side, it cannot discriminate inline from "bar-attached" items, and it cannot get the location of inline objects found. So I had it add text only at the beginning of the mail body.

2. I see the problem with any email I tried. For instance, I have created an email, and inserted a picture with Insert -> Picture. After sending the email, I worked with the email in my Sent Items folder.

3. I am attaching an image of a sample email that I used for testing.

   

4. It might be the case that objMsg.HTMLBody could never work, and that I should go with WordEditor, after reading this official page for Outlook 2007: "17.5 Using WordEditor The Outlook object model itself provides no direct way to determine the position of the cursor in an item body. However, since the editor for every item body (except on “sticky notes” and distribution lists) is a special version of Microsoft Word, you can use Word techniques not only to add text at the insertion point, but also to add formatted text anywhere in the item, or even to add a picture."

5. Possibly relevant links:

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

My code:

    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

The WordEditor basically is a word Document if I remember correctly, so you should be able to do something similar to (tested in Word, may need tweak for Outlook), assuming an object variable like doc to represent the Document:

Revised & tested in 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

Here is an example macro to process incoming mailitems, and replace the embedded images with text. Note the need to UnProtect the document:

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