VBA to take image file path text in bookmark and insert image at bookmark

[JayRay]

Hi all,

I have a word document that is bookmarked so that the each bookmark is filled with the contents of a cell from an excel sheet. For example bookmark 'logo1' will draw from D5, 'logo2' from D6 and so on. Thee bookmarks are filled with vba in excel.

Each of the cells being referenced contain the file path of a .png image. So, when the bookmark is filled it contains text such as s:\picture1.png or s:\otherexample.png. Instead , I would like to create a vba in word so that the text of 's:\picture1.png' that is iflling a bookmark is to be cut and replaced with the image that the file path leads to. Basically to have no text at the bookmark, but to have an image instead - and to do this for each of the ten bookmarks.

I have ten bookmarks - labelled logo1 to logo10. Unfortunately the 10 cells in the excel sheet are dynamic based on other selection made in the workbook - so I can't just say cell x = image file path 'y'.

Any help appreciated!! Thanks :)

[macropod]

Cross-posted at: https://www.excelforum.com/excel-programming-vba-macros/1230267-vba-to-cut-image-file-path-from-word-bookmark-and-replace-with-inserted-image.html#post4896620

Please read VBA Express' policy on Cross-Posting in item 3 of the rules: http://www.vbaexpress.com/forum/faq.php?faq=new_faq_item#faq_new_faq_item3

[gmayor]

Perhaps something along the lines of the following

Option Explicit

Sub FillBookmarks()
'Graham Mayor - http://www.gmayor.com - Last updated - 12 May 2018
Dim oBM As Bookmark
Dim strPath As String
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
For Each oBM In ActiveDocument.Bookmarks
strPath = Trim(oBM.Range.Text)
If Right(LCase(strPath), 4) = ".png" Then
If fso.FileExists(strPath) Then
ImageToBM oBM.Name, strPath
End If
End If
Next oBM
lbl_Exit:
Set fso = Nothing
Set oBM = Nothing
Exit Sub
End Sub

Private Sub ImageToBM(strbmName As String, strImagePath As String)
'Graham Mayor - http://www.gmayor.com
Dim oRng As Range
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FileExists(strImagePath) Then
With ActiveDocument
On Error GoTo lbl_Exit
Set oRng = .Bookmarks(strbmName).Range
oRng.Text = ""
oRng.InlineShapes.AddPicture _
FileName:=strImagePath, LinkToFile:=False, _
SaveWithDocument:=True
oRng.End = oRng.End + 1
oRng.Bookmarks.Add strbmName
End With
End If
lbl_Exit:
Set fso = Nothing
Set oRng = Nothing
Exit Sub
End Sub

[macropod]

I have a word document that is bookmarked so that the each bookmark is filled with the contents of a cell from an excel sheet. For example bookmark 'logo1' will draw from D5, 'logo2' from D6 and so on. Thee bookmarks are filled with vba in excel.

Each of the cells being referenced contain the file path of a .png image. So, when the bookmark is filled it contains text such as s:\picture1.png or s:\otherexample.png. Instead , I would like to create a vba in word so that the text of 's:\picture1.png' that is iflling a bookmark is to be cut and replaced with the image that the file path leads to.
That's an incredibly round-about way of doing things. Since you already have the picture's path & name in Excel, why not simply use that to insert the image directly into the Word document at the bookmark instead?

[JayRay]

Thanks gmayor - I will give it a shot and let you know how it goes. Really appreciate the reply. Macropod - simply because I have no idea what I am doing!!! If you have a solution I'd love to hear it. I'm very new to this and flying by the seat of my pants. Not trying to be lazy, but just at the start of my learning.

[macropod]

Well, without seeing your Excel code, it's impossible to say what (minor) changes it needs to make that a reality.

[JayRay]

Hi, it is very basic stuff. Essentially I have a button that opens an existing template which has bookmarks that are then populated. Each of the bookmarks which have 'logo' in the name are being populated by the contents of column D (D5, D6, D7 etc) - with each of the column D cells housing the filepath of an image. Instead of the filepath being pasted into the bookmark I would like the image itself to be pasted in.

Option Explicit
Sub bookmark()
Dim objWord As Object
Dim wb As Workbook
Dim ws As Worksheet

Set wb = ActiveWorkbook
Set ws = Sheets("Front page")
Set objWord = CreateObject("Word.Application")
objWord.Visible = True
objWord.Documents.Open (https://protect-au.mimecast.com/s/RHSCCk8vzVf5YgkpF2AOGj?domain=objword.documents.open) "S:\xxxxx\xxxx\xxxx\xxxx.docm"

With objWord.ActiveDocument
.Bookmarks("jobrole").Range.Text = ws.Range("B4").Value
.Bookmarks("chat1").Range.Text = ws.Range("B5").Value
.Bookmarks("logo1").Range.Text = ws.Range("D5").Value
.Bookmarks("blurb1").Range.Text = ws.Range("E5").Value
.Bookmarks("chat2").Range.Text = ws.Range("B6").Value
.Bookmarks("logo2").Range.Text = ws.Range("D6").Value
.Bookmarks("blurb2").Range.Text = ws.Range("E6").Value
.Bookmarks("chat3").Range.Text = ws.Range("B7").Value
.Bookmarks("logo3").Range.Text = ws.Range("D3").Value
.Bookmarks("blurb3").Range.Text = ws.Range("E7").Value
.Bookmarks("chat4").Range.Text = ws.Range("B8").Value
.Bookmarks("logo4").Range.Text = ws.Range("D8").Value
.Bookmarks("blurb4").Range.Text = ws.Range("E8").Value
.Bookmarks("chat5").Range.Text = ws.Range("B9").Value
.Bookmarks("logo5").Range.Text = ws.Range("D9").Value
.Bookmarks("blurb5").Range.Text = ws.Range("E9").Value
.Bookmarks("chat6").Range.Text = ws.Range("B10").Value
.Bookmarks("logo6").Range.Text = ws.Range("D10").Value
.Bookmarks("blurb6").Range.Text = ws.Range("E10").Value
.Bookmarks("chat7").Range.Text = ws.Range("B11").Value
.Bookmarks("logo7").Range.Text = ws.Range("D11").Value
.Bookmarks("blurb7").Range.Text = ws.Range("E11").Value
.Bookmarks("chat8").Range.Text = ws.Range("B12").Value
.Bookmarks("logo8").Range.Text = ws.Range("D12").Value
.Bookmarks("blurb8").Range.Text = ws.Range("E12").Value
.Bookmarks("chat9").Range.Text = ws.Range("B13").Value
.Bookmarks("logo9").Range.Text = ws.Range("D13").Value
.Bookmarks("blurb9").Range.Text = ws.Range("E13").Value
.Bookmarks("chat10").Range.Text = ws.Range("B14").Value
.Bookmarks("logo10").Range.Text = ws.Range("D14").Value
.Bookmarks("blurb10").Range.Text = ws.Range("E14").Value
End With

Set objWord = Nothing
End Sub

Thanks for any assistance.

[gmayor]

Paul is right in that the methodology is somewhat circuitous - though it works. You can adapt the function to allow it to work from Excel and insert the images in a single process e.g. as follows. I guess for a more robust system you would use error handling to establish that the bookmarks exist and that the files called exist, however ...


Option Explicit

Sub bookmark()
Dim objWord As Object
Dim wb As Workbook
Dim ws As Worksheet

Set wb = ActiveWorkbook
Set ws = Sheets("Front page")
Set objWord = CreateObject("Word.Application")
objWord.Visible = True
objWord.Documents.Open "S:\xxxxx\xxxx\xxxx\xxxx.docm"

On Error Resume Next
ImageToBM objWord.ActiveDocument, "jobrole", ws.Range("B4").value
ImageToBM objWord.ActiveDocument, "chat1", ws.Range("B5").value
ImageToBM objWord.ActiveDocument, "logo1", ws.Range("D5").value
ImageToBM objWord.ActiveDocument, "blurb1", ws.Range("E5").value
ImageToBM objWord.ActiveDocument, "chat2", ws.Range("B6").value
ImageToBM objWord.ActiveDocument, "logo2", ws.Range("D6").value
ImageToBM objWord.ActiveDocument, "blurb2", ws.Range("E6").value
ImageToBM objWord.ActiveDocument, "chat3", ws.Range("B7").value
ImageToBM objWord.ActiveDocument, "logo3", ws.Range("D3").value
ImageToBM objWord.ActiveDocument, "blurb3", ws.Range("E7").value
ImageToBM objWord.ActiveDocument, "chat4", ws.Range("B8").value
ImageToBM objWord.ActiveDocument, "logo4", ws.Range("D8").value
ImageToBM objWord.ActiveDocument, "blurb4", ws.Range("E8").value
ImageToBM objWord.ActiveDocument, "chat5", ws.Range("B9").value
ImageToBM objWord.ActiveDocument, "logo5", ws.Range("D9").value
ImageToBM objWord.ActiveDocument, "blurb5", ws.Range("E9").value
ImageToBM objWord.ActiveDocument, "chat6", ws.Range("B10").value
ImageToBM objWord.ActiveDocument, "logo6", ws.Range("D10").value
ImageToBM objWord.ActiveDocument, "blurb6", ws.Range("E10").value
ImageToBM objWord.ActiveDocument, "chat7", ws.Range("B11").value
ImageToBM objWord.ActiveDocument, "logo7", ws.Range("D11").value
ImageToBM objWord.ActiveDocument, "blurb7", ws.Range("E11").value
ImageToBM objWord.ActiveDocument, "chat8", ws.Range("B12").value
ImageToBM objWord.ActiveDocument, "logo8", ws.Range("D12").value
ImageToBM objWord.ActiveDocument, "blurb8", ws.Range("E12").value
ImageToBM objWord.ActiveDocument, "chat9", ws.Range("B13").value
ImageToBM objWord.ActiveDocument, "logo9", ws.Range("D13").value
ImageToBM objWord.ActiveDocument, "blurb9", ws.Range("E13").value
ImageToBM objWord.ActiveDocument, "chat10", ws.Range("B14").value
ImageToBM objWord.ActiveDocument, "logo10", ws.Range("D14").value
ImageToBM objWord.ActiveDocument, "blurb10", ws.Range("E14").value

Set wb = Nothing
Set ws = Nothing
Set objWord = Nothing
End Sub

Private Sub ImageToBM(oDoc As Object, strbmName As String, strImagePath As String)
'Graham Mayor - http://www.gmayor.com
Dim oRng As Object
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FileExists(strImagePath) Then
With oDoc
On Error GoTo lbl_Exit
Set oRng = oDoc.bookmarks(strbmName).Range
oRng.Text = ""
oRng.InlineShapes.AddPicture _
FileName:=strImagePath, LinkToFile:=False, _
SaveWithDocument:=True
oRng.End = oRng.End + 1
oRng.bookmarks.Add strbmName
End With
End If
lbl_Exit:
Set fso = Nothing
Set oRng = Nothing
Exit Sub
End Sub

[macropod]

I suspect not all the Excel values refer to images, rather only those with name's like 'logo' do. For such cases you could use code like:

Dim i As Long, j As Long
With ActiveDocument
For i = 1 To 10
Select Case i
Case 3: j = i
Case Else: j = i + 4
End Select
If Dir(ws.Range("D" & j).Value) <> "" Then
.InlineShapes.AddPicture ws.Range("D" & j).Value, , , .Bookmarks("logo" & i).Range
End If
Next
End With
The rest you can continue to populate as you're already doing, though I'm sure you can see from the above how a loop could be used to update those, too.

[JayRay]

Thanks to both of you for your time - very much appreciated!!! Macropod - I will use a loop solution for the 'blurb' and 'chat' bookmarks once I have dialed in the 'logo' appearing. I am getting a 'type mismatch' error when running this code. I am getting the first two images logo1, logo2 filling as I wish, but getting blanks for logo 3 through to 10. I'm sorry if I'm missing something very basic - I can see how the loop works now, so am very comfortable there - but can't see a reason as to why there is an error for the third image. Any help greatly appreciated :)

Option Explicit
Sub bookmark()
Dim objWord As Object
Dim wb As Workbook
Dim ws As Worksheet


Set wb = ActiveWorkbook
Set ws = Sheets("Front page")
Set objWord = CreateObject("Word.Application")


objWord.Visible = True
objWord.Documents.Open "S:\xxxxxx.docm"


With objWord.ActiveDocument
.Bookmarks("jobrole").Range.Text = ws.Range("B4").Value
.Bookmarks("chat1").Range.Text = ws.Range("B5").Value
.Bookmarks("blurb1").Range.Text = ws.Range("E5").Value
.Bookmarks("chat2").Range.Text = ws.Range("B6").Value
.Bookmarks("blurb2").Range.Text = ws.Range("E6").Value
.Bookmarks("chat3").Range.Text = ws.Range("B7").Value
.Bookmarks("blurb3").Range.Text = ws.Range("E7").Value
.Bookmarks("chat4").Range.Text = ws.Range("B8").Value
.Bookmarks("blurb4").Range.Text = ws.Range("E8").Value
.Bookmarks("chat5").Range.Text = ws.Range("B9").Value
.Bookmarks("blurb5").Range.Text = ws.Range("E9").Value
.Bookmarks("chat6").Range.Text = ws.Range("B10").Value
.Bookmarks("blurb6").Range.Text = ws.Range("E10").Value
.Bookmarks("chat7").Range.Text = ws.Range("B11").Value
.Bookmarks("blurb7").Range.Text = ws.Range("E11").Value
.Bookmarks("chat8").Range.Text = ws.Range("B12").Value
.Bookmarks("blurb8").Range.Text = ws.Range("E12").Value
.Bookmarks("chat9").Range.Text = ws.Range("B13").Value
.Bookmarks("blurb9").Range.Text = ws.Range("E13").Value
.Bookmarks("chat10").Range.Text = ws.Range("B14").Value
.Bookmarks("blurb10").Range.Text = ws.Range("E14").Value


Dim i As Long, j As Long
For i = 1 To 10
Select Case i
Case 3: j = i
Case Else: j = i + 4
End Select
If Dir(ws.Range("D" & j).Value) <> "" Then
.InlineShapes.AddPicture ws.Range("D" & j).Value, , , .Bookmarks("logo" & i).Range
End If
Next

End With


End Sub

[JayRay]

Ah - I can see that I had a typo originally with D3 referenced to 'logo3' instead of D7 - hence the 'Case 3'. Have now got this and it appears to be working!! Thank you both so much for helping with my learning!

Option Explicit
Sub bookmark()
Dim objWord As Object
Dim wb As Workbook
Dim ws As Worksheet


Set wb = ActiveWorkbook
Set ws = Sheets("Front page")
Set objWord = CreateObject("Word.Application")


objWord.Visible = True
objWord.Documents.Open "S:\xxxx.docm"


With objWord.ActiveDocument
.Bookmarks("jobrole").Range.Text = ws.Range("B4").Value
.Bookmarks("chat1").Range.Text = ws.Range("B5").Value
.Bookmarks("blurb1").Range.Text = ws.Range("E5").Value
.Bookmarks("chat2").Range.Text = ws.Range("B6").Value
.Bookmarks("blurb2").Range.Text = ws.Range("E6").Value
.Bookmarks("chat3").Range.Text = ws.Range("B7").Value
.Bookmarks("blurb3").Range.Text = ws.Range("E7").Value
.Bookmarks("chat4").Range.Text = ws.Range("B8").Value
.Bookmarks("blurb4").Range.Text = ws.Range("E8").Value
.Bookmarks("chat5").Range.Text = ws.Range("B9").Value
.Bookmarks("blurb5").Range.Text = ws.Range("E9").Value
.Bookmarks("chat6").Range.Text = ws.Range("B10").Value
.Bookmarks("blurb6").Range.Text = ws.Range("E10").Value
.Bookmarks("chat7").Range.Text = ws.Range("B11").Value
.Bookmarks("blurb7").Range.Text = ws.Range("E11").Value
.Bookmarks("chat8").Range.Text = ws.Range("B12").Value
.Bookmarks("blurb8").Range.Text = ws.Range("E12").Value
.Bookmarks("chat9").Range.Text = ws.Range("B13").Value
.Bookmarks("blurb9").Range.Text = ws.Range("E13").Value
.Bookmarks("chat10").Range.Text = ws.Range("B14").Value


.Bookmarks("blurb10").Range.Text = ws.Range("E14").Value


Dim i As Long, j As Long
For i = 1 To 10
Select Case i
Case i: j = i + 4
End Select
If Dir(ws.Range("D" & j).Value) <> "" Then
.InlineShapes.AddPicture ws.Range("D" & j).Value, , , .Bookmarks("logo" & i).Range
End If
Next

End With


End Sub

[gmayor]

The Case statement is unnecessary


For i = 1 To 10
j = i + 4
If Dir(ws.Range("D" & j).value) <> "" Then
.InlineShapes.AddPicture ws.Range("D" & j).value, , , .Bookmarks("logo" & i).Range
End If
Next i

or

For i = 1 To 10
If Dir(ws.Range("D" & i + 4).value) <> "" Then
.InlineShapes.AddPicture ws.Range("D" & i + 4).value, , , .Bookmarks("logo" & i).Range
End If
Next i

would work

[macropod]

And your overall code could be reduced to:

Sub SendToBookmarks()
Dim ws As Worksheet, objWord As Object, i As Long
Set ws = ActiveWorkbook.Sheets("Front page")
Set objWord = CreateObject("Word.Application")
With objWord
.Visible = True
.Documents.Open "S:\xxxxxx.docm", , False, False
With .ActiveDocument
.Bookmarks("jobrole").Range.Text = ws.Range("B4").Value
For i = 1 To 10
If Dir(ws.Range("D" & i + 4).Value) <> "" Then
.InlineShapes.AddPicture ws.Range("D" & i + 4).Value, , , .Bookmarks("logo" & i).Range
End If
.Bookmarks("chat" & i).Range.Text = ws.Range("B" & i + 4).Value
.Bookmarks("blurb" & i).Range.Text = ws.Range("E" & i + 4).Value
Next
End With
End With
End Sub
PS: When posting code, please structure your code and use the code tags, indicated by the # button on the posting menu. Without them, your code loses much of whatever structure it had.

[JayRay]

Thanks macropod - greatly appreciated ;)