Paste Excel range as picture into a Word doc and Resize the picture

[jerry12302]

I'm trying to use Excel VBA to resize a picture in a Word document after pasting an Excel range into the document. I have tried numerous ways and nothing is working.

Here is the code I am using, everything works except the resizing attempts:

Sub TestCopyExcelToWord()

'(1) Open an existing blank Word Doc that has a header and footer (used as a template),
' path and name identified in Excel range "BlankWordDoc".
'(2) Copy the Excel range "Invoice" as a picture
'(3) Paste the picture into the Word Doc
'(4) Resize the picture because it is too small [THIS IS THE CODE NEEDED]
'(5) Save the Word Doc using the file name identified in the Excel range "PathFileName"
'(6) Close Word

'All the code works except step (4) to resize the picture.


Dim oWord
Set oWord = CreateObject("Word.Application")

Dim oDoc
Set oDoc = CreateObject("Word.Document")

Dim myWordDoc As String
myWordDoc = Range("BlankWordDoc").Value
Const sDocPath As String = myWordDoc

Dim rRange1 As Range
Set rRange1 = ActiveSheet.Range("Invoice")

Dim myFile As String
myFile = Range("PathFileName").Value

Set oDoc = GetObject(sDocPath)
Set oWord = oDoc.Parent
oWord.Visible = True

rRange1.CopyPicture xlPrinter
oDoc.ActiveWindow.Selection.PasteSpecial


'BEGIN CODE NEEDED HERE: TO RESIZE THE PICTURE, HEIGHT = 550, WIDTH = 550

'Tried the below code, it does not work, picture size does not change.
'With oDoc
' Set wdImg = .InlineShapes(1)
' With wdImg
' .Height = 550
' .Width = 550
' End With
'End With

'Also tried the below code, it does not work either.
'Selection.ShapeRange.Height = 550
'Selection.ShapeRange.Width = 550

'END CODE NEEDED HERE


oDoc.SaveAs2 myFile, 12, False, "", True
oDoc.Close
oWord.Quit

Set oDoc = Nothing
Set rRange1 = Nothing

End Sub

 

[Macropod]

For example:

Sub TestCopyExcelToWord()
Dim wdObj As Object, wdDoc  As Object, wdShp  As Object
Set wdObj = CreateObject("Word.Application")
Set wdDoc = wdObj.Documents.Add(ActiveSheet.Range("BlankWordDoc").Value)
ActiveSheet.Range("Invoice").Copy
Set wdShp = wdDoc.Range.PasteSpecial(, , 1, , 9)
wdShp.Height = 550: wdShp.Width = 550
wdDoc.SaveAs2 ActiveSheet.Range("PathFileName").Value, 12, False, "", True
oDoc.SaveAs2 myFile, 12, False, "", True
wdDoc.Close False: wdObj.Quit
Set wdShp = Nothing: Set wdDoc = Nothing: Set wdObj = Nothing
End Sub

 

[jerry12302]

For example:

Sub TestCopyExcelToWord()
Dim wdObj As Object, wdDoc  As Object, wdShp  As Object
Set wdObj = CreateObject("Word.Application")
Set wdDoc = wdObj.Documents.Add(ActiveSheet.Range("BlankWordDoc").Value)
ActiveSheet.Range("Invoice").Copy
Set wdShp = wdDoc.Range.PasteSpecial(, , 1, , 9)
wdShp.Height = 550: wdShp.Width = 550
wdDoc.SaveAs2 ActiveSheet.Range("PathFileName").Value, 12, False, "", True
oDoc.SaveAs2 myFile, 12, False, "", True
wdDoc.Close False: wdObj.Quit
Set wdShp = Nothing: Set wdDoc = Nothing: Set wdObj = Nothing
End Sub

Thank you for your response. A little trouble with the line: Set wdDoc = wdObj.Documents.Add(ActiveSheet.Range("BlankWordDoc").Value), received a run time error 1004 application-defined or object-defined error. I removed all instances of ActiveSheet. and that error stopped.

The bigger problem is the line: Set wdShp = wdDoc.Range.PasteSpecial(, , 1, , 9), received a run time error 424 object required.

Any idea how to fix that?

Thank you for your time on this.

Jerry

 

[Macropod]

I haven't got time to work though this in detail right now, but replacing:

Set wdShp = wdDoc.Range.PasteSpecial(, , 1, , 9)

with:

wdDoc.Range.PasteSpecial , , 1, , 9
Set wdShp = wdDoc.Shapes(1)

should suffice.

 

[jerry12302]

I haven't got time to work though this in detail right now, but replacing:

Set wdShp = wdDoc.Range.PasteSpecial(, , 1, , 9)

with:

wdDoc.Range.PasteSpecial , , 1, , 9
Set wdShp = wdDoc.Shapes(1)

should suffice.

That did the trick, thank you, works great now.

I also made a slight change to get rid of the border and gridlines in the pic, by replacing:
Range("Invoice").Copy
with:
Range("Invoice").CopyPicture Appearance:=xlPrinter, Format:=xlPicture