Copy images from Excel to header of Word

[Crikriek]

Hello,

I have a multiple sheets excel than I transform into a word via VBA.

On one of the sheets are two pictures, those two pictures i'd like to copy them in the header of the word document. One picture on the left-side and the other one on the right-side.

How could I do this ?

Thanks in advance for your help

[gmayor]

Without access to the workbook it's something of a step in the dark, but the following could work. As you know the worksheet name, you could set that for xlSheet instead of looping through all the sheets to find a sheet with two shapes.


Option Explicit

Sub Macro1()
Dim xlapp As Object
Dim xlbook As Object
Dim xlSheet As Object
Dim oShape As Object
Dim oWdShape As InlineShape
Dim oRng As Range
Const strSource As String = "C:\Path\Workbook.xlsx" 'the name of the workbook
On Error Resume Next
Set xlapp = GetObject(, "Excel.Application")
If Err Then
Set xlapp = CreateObject("Excel.Application")
End If
On Error GoTo 0
Set xlbook = xlapp.workbooks.Open(strSource)
For Each xlSheet In xlbook.worksheets
If xlSheet.Shapes.Count = 2 Then
Set oShape = xlSheet.Shapes(1)
oShape.Copy
Set oRng = ActiveDocument.Sections(1).Headers(wdHeaderFooterPrimary).Range
oRng.Collapse 1
oRng.PasteSpecial link:=False, _
DataType:=14, _
Placement:=wdInLine, _
DisplayAsIcon:=False
Set oRng = ActiveDocument.Sections(1).Headers(wdHeaderFooterPrimary).Range
Set oWdShape = oRng.InlineShapes(1)
Set oShape = xlSheet.Shapes(2)
oShape.Copy
oRng.Start = oWdShape.Range.End + 1
oRng.Text = vbTab & vbTab
oRng.Collapse 0
oRng.PasteSpecial link:=False, _
DataType:=14, _
Placement:=wdInLine, _
DisplayAsIcon:=False
Exit For
End If
Next xlSheet
End Sub

[Crikriek]

Thank you for your answer !

Is it possible to have it shorter ? As the code is pretty long I try to find ways to make less code lines.

Here below is a code that I just tried for one picture :

'Copy the image in the excel sheet
Shapes.Range(Array("Group5")).Copy
'Paste it on the word document header
docWord.Sections(1).Headers(1).Range.Paste

However I got the error message 424 : Object Required

Do you know how I could fix it ? Is that a good approach to do it with less lines ?

Thanks !

Kind regards,

Christophe

[gmayor]

You fix it by using the longer code. :)

[Crikriek]

Thanks ! I tried your code and I get a type mismatch with the line Set oRng = ActiveDocument.Sections(1).Headers(wdHeaderFooterPrimary).Range

I tried changing oRng into a Variant. I did not get this type mismatch error however when I run the code it crashes the word application. Any idea How I could fix this ?

[Crikriek]

As a complement, I identified the bug occurs at the following line : oRng.PasteSpecial

[Crikriek]

It works fine now, Not sure what has changed but thanks a lot for your help !