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

jerry12302

Active Member
Joined
Apr 18, 2005
Messages
417
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
 

Excel Facts

Format cells as currency
Select range and press Ctrl+Shift+4 to format cells as currency. (Shift 4 is the $ sign).

Macropod

Retired Moderator
Joined
Aug 27, 2007
Messages
3,570
For example:
VBA Code:
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

Active Member
Joined
Apr 18, 2005
Messages
417
For example:
VBA Code:
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

Retired Moderator
Joined
Aug 27, 2007
Messages
3,570
I haven't got time to work though this in detail right now, but replacing:
VBA Code:
Set wdShp = wdDoc.Range.PasteSpecial(, , 1, , 9)
with:
VBA Code:
wdDoc.Range.PasteSpecial , , 1, , 9
Set wdShp = wdDoc.Shapes(1)
should suffice.
 
Solution

jerry12302

Active Member
Joined
Apr 18, 2005
Messages
417
I haven't got time to work though this in detail right now, but replacing:
VBA Code:
Set wdShp = wdDoc.Range.PasteSpecial(, , 1, , 9)
with:
VBA Code:
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
 

Forum statistics

Threads
1,141,403
Messages
5,706,257
Members
421,435
Latest member
Yoga15

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top