How to copy excel embedded image to word header in table in specific cell?

Question

I'm calling procedure from my main procedure to make header in word, that contains 2 lines of text, then image, then 1 line of text. I'm trying to do that with table that has 1 column and 4 rows. In 3rd row I want picture. Picture is stored on sheet in excel file, that contains all data for report in word. Paste is not working. Can't figure out how to get image in cell.

Found that picture can be added from file, but I don't want to keep picture in separate file, because if I move my excel file I have to move picture file also.

'Procedure, to create header
Sub MakeHeader()
Dim StrArr(1 To 2) As String
Dim RangeObj As Word.Range
    'load text from excel table
    StrArr(1) = ActiveSheet.Range("A26").Value
    StrArr(2) = ActiveSheet.Range("A27").Value

    'to create table
    Set RangeObj = ActiveDocument.Sections(1).Headers(1).Range
    RangeObj.Tables.Add Range:=RangeObj, NumRows:=4, NumColumns:=1

   'populate table
    '//
    RangeObj.Tables(1).Cell(1, 1).Range.Text = StrArr(1)
    RangeObj.Tables(1).Cell(2, 1).Range.Text = StrArr(2)
    'copy picture that is embedded in excel sheet
    'Shapes(4), because there are more then one object in sheet
    ActiveSheet.Shapes(4).CopyPicture xlScreen, xlBitmap
    RangeObj.Tables(1).Cell(3, 1).Application.Selection.Paste
    '//

    'center
    ActiveDocument.Sections(1).Headers(1).Range.ParagraphFormat.Alignment = 1
End Sub

Answer 1

The main issue in the code is in the line

RangeObj.Tables(1).Cell(3, 1).Application.Selection.Paste

The Picture is getting pasted in the document itself as it is being referred to Application object selection (normally it is not in the header table but in the main document). So changing the line to

RangeObj.Tables(1).Cell(3, 1).Range.Paste

would paste it in the header table as shown below

Also instead of referring ActiveDocument directly in excel VBA (causing problem in some instances of run) it may be referred via Word Application.

The Full modified code:

Sub MakeHeader()
Dim StrArr(1 To 2) As String
Dim RangeObj As Word.Range
'Next line Added for test
Dim wd As Word.Application
    'load text from excel table
    StrArr(1) = ActiveSheet.Range("A26").Value
    StrArr(2) = ActiveSheet.Range("A27").Value

    'to create table
    'Next Three line Added for test
    Set wd = CreateObject("Word.Application")
    wd.Visible = True
    wd.Documents.Add

    'Wd i.e. referance to Word application added to ActiveDocument
    Set RangeObj = wd.ActiveDocument.Sections(1).Headers(1).Range
    RangeObj.Tables.Add Range:=RangeObj, NumRows:=4, NumColumns:=1

   'populate table
    '//
    RangeObj.Tables(1).Cell(1, 1).Range.Text = StrArr(1)
    RangeObj.Tables(1).Cell(2, 1).Range.Text = StrArr(2)
    'copy picture that is embedded in excel sheet
    'Shapes(4), because there are more then one object in sheet
    'shapes(4) modified to Shapes(1) for test. Change to Your requirement
    ActiveSheet.Shapes(1).CopyPicture xlScreen, xlBitmap

    'This line was causing Problem as Range.Application was referring to Word application
    ' And picture is getting pasted in the document not in header Table
    RangeObj.Tables(1).Cell(3, 1).Range.Paste

    '//

    'center
    'Wd i.e. referance to Word application added to ActiveDocument
    wd.ActiveDocument.Sections(1).Headers(1).Range.ParagraphFormat.Alignment = 1
End Sub

Answer 2

For someone in future that wants to do something similar, but without Table

'Procedure, to create header
Sub MakeHeader(WApp As Object)
Dim StrArr(1 To 3) As String
Dim ImageObj As Excel.Shape
Dim Doc As Word.Document
Dim i As Long
Dim Count As Long
    'load text from excel file
    StrArr(1) = ActiveSheet.Range("A26").Value
    StrArr(2) = ActiveSheet.Range("A27").Value
    StrArr(3) = ActiveSheet.Range("A28").Value
    'create object to hold picture
    Set ImageObj = ActiveSheet.Shapes(4)
    Set Doc = WApp.ActiveDocument
    With Doc.Sections(1).Headers(1).Range
        'centers text
        .ParagraphFormat.Alignment = 1
        'choosing font
        .Font.Name = "Verdana"
        .Font.Size = 9
        'writes text
        .InsertAfter StrArr(1)
        .Paragraphs.Add
        .InsertAfter StrArr(2)
        .Paragraphs.Add
        'creates space for image
        For i = 1 To 8
            .InsertAfter vbNullString
            .Paragraphs.Add
        Next
        .InsertAfter StrArr(3)
        'change font size for paragraphs 1 and 2
        .Paragraphs(1).Range.Font.Size = 10
        .Paragraphs(2).Range.Font.Size = 10
        'copies image form excel file
        With ImageObj
            .Copy
        End With
        'collapses selection, 0 = wdCollapseEnd
        .Collapse Direction:=0
        'paste image, 3 = wdPasteMetafilePicture
        .PasteSpecial DataType:=3
        'centers image
        .ShapeRange.Align msoAlignCenters, True
        'lowers it from top of page
        .ShapeRange.Top = 35
    End With
    'counts words in header
    Count = Doc.Sections(1).Headers(1).Range.Words.Count
    'underlines last two words, count considers ".", "@" and etc. as words
    With Doc.Sections(1).Headers(1).Range
        .Words(Count - 1).Font.Underline = 1
        .Words(Count - 2).Font.Underline = 1
        .Words(Count - 3).Font.Underline = 1
        .Words(Count - 4).Font.Underline = 1
        .Words(Count - 5).Font.Underline = 1
        .Words(Count - 6).Font.Underline = 1
        .Words(Count - 7).Font.Underline = 1
        'don't need to underline comma ","
        .Words(Count - 9).Font.Underline = 1
        .Words(Count - 10).Font.Underline = 1
        .Words(Count - 11).Font.Underline = 1
        .Words(Count - 12).Font.Underline = 1
        .Words(Count - 13).Font.Underline = 1
        .Words(Count - 14).Font.Underline = 1
        .Words(Count - 15).Font.Underline = 1
    End With
End Sub

Answer 3

Try:

Sub MakeWordHeader()
Dim wdApp As New Word.Application, wdDoc As Word.Document
Dim wdRng As Word.Range, wdTbl As Word.Table
Dim xlSht As Excel.Worksheet: Set xlSht = ActiveSheet
With wdApp
  .Visible = True
  Set wdDoc = .Documents.Add
  With wdDoc
    Set wdRng = .Sections(1).Headers(1).Range
    Set wdTbl = .Tables.Add(Range:=wdRng, NumRows:=4, NumColumns:=1)
    With wdTbl
      .Cell(1, 1).Range.Text = xlSht.Range("A26").Text
      .Cell(2, 1).Range.Text = xlSht.Range("A27").Text
      xlSht.Shapes(4).CopyPicture xlScreen, xlBitmap
      .Cell(3, 1).Range.Paste
    End With
    wdRng.ParagraphFormat.Alignment = wdAlignParagraphCenter
  End With
End With
End Sub