CODEWITHSUNDEEP
excelvbaimagems-wordbookmarks
Tristan Lessard
Tristan Lessard

Reputation: 1

Trying to create an enclosing bookmark after pasting a picture from Excel into Word using VBA

I've been looking around a lot on internet, on this forum and so many others and can't seem to find my answer which I thought would be much more simple than it is currently.

I am writing a code to automatize a report that we have most data in excel. My code is relatively simple : Take the text in those few cells, take those graphs, copy those tables and paste all of those to specific bookmarks (as image for graphs and tables).

So far, this step is going perfect. I've tried multiple ways of coding it, mostly through loops but working with bookmarks as been very challenging and not super flexible so the code is just a repetitive set of steps, very simply written. I'm just debuting in doing inter-office apps macros, especially word. My code does exactly what is mentioned above, until I have to run it a second time. The goal is that if I run again the macro, it will run again and replace the texts, images and the tables that were initially pasted.

Here's the code :

Sub IMPORT_TO_WORD()

Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim msWord As Object

'Set worksheets
Set ws1 = ThisWorkbook.Worksheets("Tableaux")
Set ws2 = ThisWorkbook.Worksheets("Graph")
Set ws3 = ThisWorkbook.Worksheets("REFERENCE MACRO")
Set ws4 = ThisWorkbook.Worksheets("Tableaux2")


     
    Filename = ws4.Range("B3")
       
   'Open word / check if it's open
    On Error Resume Next
    Set msWord = GetObject(class:="Word.Application")
    Err.Clear
    If msWord Is Nothing Then Set msWord = CreateObject(class:="Word.Application")
    
        
    With msWord
        .Visible = True
        .Documents.Open (Filename)
        .Activate
        Application.Wait Now + #12:00:03 AM#
        


'If ws4.Range("F1") = "English" Then
On Error GoTo 0

'Set the BookMarks range
    Set BMSALES = .ActiveDocument.Bookmarks(1).Range
    Set BMSALES2 = .ActiveDocument.Bookmarks(2).Range
    Set BMLISTINGS = .ActiveDocument.Bookmarks(3).Range
    Set BMLISTINGS2 = .ActiveDocument.Bookmarks(4).Range
    Set BMMEDPRICE = .ActiveDocument.Bookmarks(5).Range
    Set BMMEDPRICE2 = .ActiveDocument.Bookmarks(6).Range
    Set BMEVO = .ActiveDocument.Bookmarks(7).Range
    Set BMEVO2 = .ActiveDocument.Bookmarks(8).Range
    Set BMMKTCOND = .ActiveDocument.Bookmarks(9).Range
    Set BMGraph1 = .ActiveDocument.Bookmarks(10).Range
    Set BMGraph2 = .ActiveDocument.Bookmarks(11).Range
    Set BMGraph3 = .ActiveDocument.Bookmarks(12).Range
    Set BMGraph4 = .ActiveDocument.Bookmarks(13).Range
    Set BMGraph5 = .ActiveDocument.Bookmarks(14).Range
    Set BMTABLE1 = .ActiveDocument.Bookmarks(15).Range
    Set BMTABLE2 = .ActiveDocument.Bookmarks(16).Range
    Set BMTABLE3 = .ActiveDocument.Bookmarks(17).Range
    Set BMTABLE4 = .ActiveDocument.Bookmarks(18).Range
 
'Insert text
    BMSALES.Text = ws3.Range("B1")
    BMSALES2.Text = ws3.Range("B2")
    BMLISTINGS.Text = ws3.Range("B3")
    BMLISTINGS2.Text = ws3.Range("B4")
    BMMEDPRICE.Text = ws3.Range("B5")
    BMMEDPRICE2.Text = ws3.Range("B6")
    BMEVO.Text = ws3.Range("B7")
    BMEVO2.Text = ws3.Range("B8")
    BMMKTCOND.Text = ws3.Range("B9")

'Insert Graphs
            ws2.ChartObjects(5).Copy
            Application.Wait Now + #12:00:01 AM#
            BMGraph1.PasteSpecial Link:=False, DataType:=wdPasteMetafilePicture, Placement:=wdInLine, DisplayAsIcon:=False
            
            ws2.ChartObjects(1).Copy
            Application.Wait Now + #12:00:01 AM#
            BMGraph5.PasteSpecial Link:=False, DataType:=wdPasteMetafilePicture, Placement:=wdInLine, DisplayAsIcon:=False
            
            ws2.ChartObjects(2).Copy
            Application.Wait Now + #12:00:01 AM#
            BMGraph4.PasteSpecial Link:=False, DataType:=wdPasteMetafilePicture, Placement:=wdInLine, DisplayAsIcon:=False
            
            ws2.ChartObjects(3).Copy
            Application.Wait Now + #12:00:01 AM#
            BMGraph3.PasteSpecial Link:=False, DataType:=wdPasteMetafilePicture, Placement:=wdInLine, DisplayAsIcon:=False

            ws2.ChartObjects(4).Copy
            Application.Wait Now + #12:00:01 AM#
            BMGraph2.PasteSpecial Link:=False, DataType:=wdPasteMetafilePicture, Placement:=wdInLine, DisplayAsIcon:=False

'Insert tables           
            ws1.Range("D3:P11").Copy
            Application.Wait Now + #12:00:01 AM#
            BMTABLE1.PasteSpecial Link:=False, DataType:=wdPasteMetafilePicture, Placement:=wdInLine, DisplayAsIcon:=False
            
            ws1.Range("D22:P30").Copy
            Application.Wait Now + #12:00:01 AM#
            BMTABLE2.PasteSpecial Link:=False, DataType:=wdPasteMetafilePicture, DisplayAsIcon:=False, Placement:=wdInLine
            
            ws1.Range("D41:P49").Copy
            Application.Wait Now + #12:00:01 AM#
            BMTABLE3.PasteSpecial Link:=False, DataType:=wdPasteMetafilePicture, DisplayAsIcon:=False, Placement:=wdInLine
            
            ws1.Range("D60:P68").Copy
            Application.Wait Now + #12:00:01 AM#
            BMTABLE4.PasteSpecial Link:=False, DataType:=wdPasteMetafilePicture, DisplayAsIcon:=False, Placement:=wdInLine
            
            Application.CutCopyMode = False
            
   'Put the bookmark back in the word doc to be able to use the macro again         
    ActiveDocument.Bookmarks.Add Name:="ASales", Range:=BMSALES
    ActiveDocument.Bookmarks.Add Name:="ASales2", Range:=BMSALES2
    ActiveDocument.Bookmarks.Add Name:="BLISTINGS", Range:=BMLISTINGS
    ActiveDocument.Bookmarks.Add Name:="BLISTINGS2", Range:=BMLISTINGS2
    ActiveDocument.Bookmarks.Add Name:="CMEDPRICE", Range:=BMMEDPRICE
    ActiveDocument.Bookmarks.Add Name:="CMEDPRICE2", Range:=BMMEDPRICE2
    ActiveDocument.Bookmarks.Add Name:="EVO1", Range:=BMEVO
    ActiveDocument.Bookmarks.Add Name:="EVO2", Range:=BMEVO2
    ActiveDocument.Bookmarks.Add Name:="FMKTCOND", Range:=BMMKTCOND
    ActiveDocument.Bookmarks.Add Name:="GRAPH1", Range:=BMGraph1
    ActiveDocument.Bookmarks.Add Name:="GRAPH2", Range:=BMGraph2
    ActiveDocument.Bookmarks.Add Name:="GRAPH3", Range:=BMGraph3
    ActiveDocument.Bookmarks.Add Name:="GRAPH4", Range:=BMGraph4
    ActiveDocument.Bookmarks.Add Name:="GRAPH5", Range:=BMGraph5
    ActiveDocument.Bookmarks.Add Name:="TABLE1", Range:=BMTABLE1
    ActiveDocument.Bookmarks.Add Name:="TABLE2", Range:=BMTABLE2
    ActiveDocument.Bookmarks.Add Name:="TABLE3", Range:=BMTABLE3
    ActiveDocument.Bookmarks.Add Name:="TABLE4", Range:=BMTABLE4
     
End With
End Sub

For the text, it works wonders, as the bookmark that is created stays an enclosing bookmark. It gets complicated for the image as the bookmark that is created becomes a placeholder bookmark, not enclosing the pictures so when I use the macro again the images add up and don't replace it.

I've tried different ways of doing it and can't find anything. The closest I feel I was was with this :

ActiveDocument.Bookmarks.Add Name:="GRAPH1", Range:=BMGraph1
BMGraph1.Select
ActiveDocument.Selection.Move Unit:=wdCharacter, Count:=1
ActiveDocument.Bookmarks.Add , Range:=Selection.Range

So that we select the newly placed placeholder, move the selection one character (I tried Selection.MoveRight as well) so that the image is selected and then reinsert the bookmark and ensure it's enclosing and then the macro could be run over and over.

But for some reason I get a "object doesn't support this property or method vba" error at the Selection.Move which I have trouble understanding since it definitely a supported method for Selection.

I've looked online for so many different solutions, which is also how I got the last piece of code (adjusted to my situation) but can't find anything that is fitting this specific situation.

I also haven't been able to resize my pasted image as I have lot of trouble finding the correct object or method to do so. Planning on using InLineShapes in said bookmarks once I am able to correctly have enclosing bookmarks.

So I'm out here, asking for your help.

Thanks in advance guys !

Upvotes: 0

Views: 353

Answers (2)

macropod
macropod

Reputation: 13505

Perhaps:

Sub IMPORT_TO_WORD()
Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet, ws4 As Worksheet
Dim ObjWd As Object, ObjDoc As Object
Dim r As Long, ArrTxtBkMk(), ArrImgBkMk(), ArrImgSrc(), ArrTblBkMk(), ArrTblSrc()
'Set worksheets
With ThisWorkbook
  Set ws1 = .Worksheets("Tableaux")
  Set ws2 = .Worksheets("Graph")
  Set ws3 = .Worksheets("REFERENCE MACRO")
  Set ws4 = .Worksheets("Tableaux2")
End With
       
'Open word / check if it's open
On Error Resume Next
Set ObjWd = GetObject(class:="Word.Application")
Err.Clear
If ObjWd Is Nothing Then
  Set ObjWd = CreateObject(class:="Word.Application")
End If
On Error GoTo 0
ArrTxtBkMk = Array(, "ASales", "ASales2", "BLISTINGS", "BLISTINGS2", _
            "CMEDPRICE", "CMEDPRICE2", "EVO1", "EVO2", "FMKTCOND")
ArrImgBkMk = Array("GRAPH1", "GRAPH2", "GRAPH3", "GRAPH4", "GRAPH5")
ArrImgSrc = Array(5, 1, 2, 3, 4)
ArrTblBkMk = Array("TABLE1", "TABLE2", "TABLE3", "TABLE4")
ArrTblSrc = Array("D3:P11", "D22:P30", "D41:P49", "D60:P68")

With ObjWd
  .Visible = True
  Set ObjDoc = .Documents.Open(ws4.Range("B3"))
  'Update Text bookmark ranges
  For r = 1 To UBound(ArrTxtBkMk)
    Call UpdateTextBookmark(ObjDoc, "" & ArrTxtBkMk(r) & "", ws3.Range("B" & r))
  Next
  'Update Image bookmark ranges
  For r = 0 To UBound(ArrImgBkMk)
    ws2.ChartObjects(ArrImgSrc(r)).Copy
    Call UpdateImageBookmark(ObjDoc, "" & ArrImgBkMk(r) & "")
  Next
  'Update table bookmark ranges
  For r = 0 To UBound(ArrTblBkMk)
    ws1.Range("" & ArrTblSrc(r) & "").Copy
    Call UpdateImageBookmark(ObjDoc, "" & ArrTblBkMk(r) & "")
  Next
End With
Application.CutCopyMode = False
End Sub

Sub UpdateTextBookmark(ObjDoc As Object, StrBkMk As String, StrTxt As String)
Dim ObjRng As Object
With ObjDoc
  If .Bookmarks.Exists(StrBkMk) Then
    Set ObjRng = .Bookmarks(StrBkMk).Range
    ObjRng.Text = StrTxt
    .Bookmarks.Add StrBkMk, ObjRng
  Else
    MsgBox StrBkMk & " bookmark NOT found!", vbExclamation
  End If
End With
Set ObjRng = Nothing
End Sub

Sub UpdateImageBookmark(ObjDoc As Object, StrBkMk As String)
Dim ObjRng As Object
With ObjDoc
  If .Bookmarks.Exists(StrBkMk) Then
    Set ObjRng = .Bookmarks(StrBkMk).Range
    With ObjRng
      .Range.Text = vbNullString
      .PasteSpecial Link:=False, DataType:=wdPasteMetafilePicture, _
        Placement:=wdInLine, DisplayAsIcon:=False
      .End = .End + 1
    End With
    .Bookmarks.Add StrBkMk, ObjRng
  Else
    MsgBox StrBkMk & " bookmark NOT found!", vbExclamation
  End If
End With
Set ObjRng = Nothing
End Sub

Upvotes: 1

Tim Williams
Tim Williams

Reputation: 166341

You will find it easier to code this if you factor out the text/image transfers into stand-alone methods you can call:

Sub Tester()

    Dim msWord As Object, doc As Object
    Set msWord = GetObject(class:="Word.Application") 'Word is open already
    Set doc = msWord.activedocument 'already have a doc open for testing
    
    SetBookMarkText doc.bookmarks("TEXT1"), Sheet1.Range("A1").Value
    ImageToBookmark doc.bookmarks("PLOT1"), Sheet1.ChartObjects(1)
    
End Sub

'Set the text in a bookmark without destroying it
Sub SetBookMarkText(bmk As Object, txt)
    Dim nm, rng
    nm = bmk.Name
    Set rng = bmk.Range
    rng.Text = txt
    rng.Parent.bookmarks.Add nm, rng
End Sub

'paste an image to a bookmark
Sub ImageToBookmark(bmk As Object, itemToCopy)
    Const wdPasteMetafilePicture = 3
    Const wdInLine = 0
    Dim rng As Object, j As Long, nm
    
    nm = bmk.Name 'get the bookmark name for later
    itemToCopy.Copy
    Set rng = bmk.Range
    'remove any previous images
    Do While rng.inlineshapes.Count > 0
        rng.inlineshapes(1).Delete
    Loop
    
    j = rng.Parent.inlineshapes.Count
    rng.PasteSpecial Link:=False, DataType:=wdPasteMetafilePicture, _
                     Placement:=wdInLine, DisplayAsIcon:=False
    'reset the bookmark so it encloses the pasted image
    rng.Parent.bookmarks.Add nm, rng.Parent.inlineshapes(j + 1).Range
End Sub

Upvotes: 0

Related Questions