Word VBA - Inserting Inline Picture from filepath in document - vba

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