Word VBA - Inserting Inline Picture from filepath in document

Question

I have a Word Document that includes as text the complete filepaths to multiple images (e.g. C:\Users\Name\Documents\Test Logos\alphatest.png). I am trying to create a macro to replace each text filepath with the image it refers to as inline shapes. The script also resizes the images. I am having trouble assigning a valid reference to the inline shape object variable using the Set statement.

((Right now, I am locating the filepaths in the Word document by manually putting "QQQ" before and after the text in the Word Document and then having the script search for text that is flanked by "QQQ." So, in the Word Document, each filepath looks like this: "QQQC:\Users\Name\Documents\Test Logos\alphatest.pngQQQ". This is a temporary kludge and does not seem to be the source of the error.))

Sub InsertAndResizeLogos()
'
' InsertAndResizeLogos Macro
' Insert logos at the correct place in the document, resize to less than 1 inch tall and 2 inches wide.
'
    Selection.HomeKey Unit:=wdStory
    With Selection.Find
        .ClearFormatting
        .Text = "QQQ*QQQ"
        .Forward = True
        .Wrap = wdFindStop
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = True
        Do While .Execute
            While Selection.Find.Found
                Dim imagePath As String
                Debug.Print Replace(Selection.Text, "QQQ", "")
                imagePath = Replace(Selection.Text, "QQQ", "")
                imagePath = Replace(imagePath, "\", "//")
                imagePath = Replace(imagePath, vbCr, "")
                Debug.Print imagePath

                Dim SHP As InlineShape
                Set SHP = Selection.InlineShapes.AddPicture(FileName:=imagePath, LinkToFile:=False, SaveWithDocument:=True)
                    SHP.LockAspectRatio = True
                    SHP.Height = InchesToPoints(1)
                If SHP.Width > InchesToPoints(2) Then
                    SHP.Width = InchesToPoints(2)
                End If
            Wend
        Loop
    End With

End Sub

If I don't convert the filepath string to VBA's preferred format (i.e., removing this line from the script:)

                imagePath = Replace(imagePath, "\", "//")

then the script successfully combs through the Word Document, finds the first filepath, and replaces it with the correct image. But then it throws a "Runtime Error 5152: This is not a valid file name." on the "Set" line and breaks.

If I do convert the filepath string to VBA format by replacing the \'s with //'s, then it does not successfully insert the image and throws a "Runtime Error 91: Object variable or With block variable not set" on the SHP.LockAspectRation=True line and breaks.

It seems like if I feed the filepath into the Set statement with //'s, it can no longer find the image. Is this something I could fix with error handling, or am I making a more fundamental mistake?

((If I set the filepath within the script, (i.e. imagePath = C:\Users\Name\Documents\Test Logos\alphatest.png), the script will successfully iterate through the entire document and replace all text with the QQQ's with that image.))

SOLUTION

Here is the final code that worked correctly:

    Sub InsertAndResizeLogos()
'
' InsertAndResizeLogos Macro
' Insert logos at the correct place in the document, resize to less than 1 inch tall and 2 inches wide.
'
Application.ScreenUpdating = False
Dim i As Long, j As Long, StrNm As String, StrErr As String, iShp As InlineShape
With Selection 'ActiveDocument.Range
  With .Find
    .ClearFormatting
    .Text = "*.[A-Za-z]{3}>"
    .Forward = True
    .Wrap = wdFindContinue
    .Format = False
    .MatchWildcards = True
    .Execute
  End With
  Do While .Find.Found
    StrNm = .Text
    If Dir(StrNm) = "" Then
      j = j + 1: StrErr = StrErr & vbCr & StrNm
    Else
      i = i + 1
      Set iShp = .InlineShapes.AddPicture(FileName:=StrNm, LinkToFile:=False, SaveWithDocument:=True)
      With iShp
        .LockAspectRatio = True
        .Height = InchesToPoints(1)
        If .Width > InchesToPoints(2) Then .Width = InchesToPoints(2)
      End With
    End If
    .Collapse wdCollapseEnd
    .Find.Execute
  Loop
End With
Application.ScreenUpdating = True
MsgBox i & " images added." & vbCr & j & " image files not found:" & StrErr
End Sub

The problem seems to have been related to pulling the filepath from Selection.Text rather than from .Find.Found.Text

This mostly uses the approach suggested below by Macropod, although applied to Selection rather than to Document.Range to maintain the "replace the text with the image" functionality. For some reason, Find.Execute's ReplaceWith parameter and Find's Replacement property refused to work no matter where in the process I called them.

Answer 1

You don't need all the QQQ circumlocution. You also don't need:

imagePath = Replace(imagePath, "\", "//")

But you should add error-checking to the code in case one or more image files is missing. Try:

Sub Demo()
Application.ScreenUpdating = False
Dim i As Long, j As Long, StrNm As String, StrErr As String, iShp As InlineShape
With ActiveDocument.Range
  With .Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = "C:\\Users\\*.[A-Za-z]{3}>"
    .Replacement.Text = ""
    .Forward = True
    .Wrap = wdFindStop
    .Format = False
    .MatchWildcards = True
    .Execute
  End With
  Do While .Find.Found
    StrNm = .Text
    If Dir(StrNm) = "" Then
      j = j + 1: StrErr = StrErr & vbCr & StrNm
    Else
      i = i + 1: .Text = vbNullString
      Set iShp = .InlineShapes.AddPicture(FileName:=StrNm, LinkToFile:=False, SaveWithDocument:=True, Range:=.Duplicate)
      With iShp
        .LockAspectRatio = True
        .Height = InchesToPoints(1)
        If .Width > InchesToPoints(2) Then .Width = InchesToPoints(2)
      End With
    End If
    .Collapse wdCollapseEnd
    .Find.Execute
  Loop
End With
Application.ScreenUpdating = True
MsgBox i & " images added." & vbCr & j & " image files not found:" & StrErr
End Sub

Answer 2

The following works for me.

I am using *png to identify the strings that end with .png.

I am then using

Right$(imagePath, Len(imagePath) - InStr(1,imagePath,":\") + 2)

to extract the string that holds the filepath on the assumption your filepaths are along the lines of C:\ etc. You could evolve this logic to suit your purposes.

I have removed the other loop and simply allowed the .Execute to continue until False.

Sub Test

    Selection.HomeKey Unit:=wdStory

    With Selection.Find
        .ClearFormatting
        .Text = "*png"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = True

        Do While .Execute

                Dim imagePath As String
                imagePath = Selection.Range.Text
                imagePath = Right$(imagePath, Len(imagePath) - InStr(1,imagePath,":\") + 2)

                Dim SHP As InlineShape
                Set SHP = Selection.InlineShapes.AddPicture(FileName:=imagePath, LinkToFile:=False, SaveWithDocument:=True)
                    SHP.LockAspectRatio = True
                    SHP.Height = InchesToPoints(1)

                If SHP.Width > InchesToPoints(2) Then
                    SHP.Width = InchesToPoints(2)
                End If
        Loop

    End With

End Sub

Reference:

https://superuser.com/questions/1009085/find-all-instances-of-a-text-and-make-it-a-hyperlink-with-a-macro