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

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 :)

Cross-posted at: https://www.excelforum.com/excel-pro...ml#post4896620

Please read VBA Express' policy on Cross-Posting in item 3 of the rules: http://www.vbaexpress.com/forum/faq...._new_faq_item3

Perhaps something along the lines of the following

Code:

---

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

---

Quote:

---

Originally Posted by JayRay

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?

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.

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

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 "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.

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 ...

Code:

---

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

---

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:

Code:

---

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.

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

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

The Case statement is unnecessary

Code:

---

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

Code:

---

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

And your overall code could be reduced to:

Code:

---

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.

Thanks macropod - greatly appreciated ;)