VBA to copy from Excel as image and paste in Word

Diag

New Member
Joined
Aug 24, 2022
Messages
5
Office Version
  1. 365
Platform
  1. Windows
Hello,

I am new to the forum and I use VBA not very often. I have used the code (similar to the code mentioned in the link below).

When I use the code it works fine, but I get the popup message that the image is too big and that it will be cut. when viewing the image in word, it is not fitted correctly. My data is in Range A1:O58.

the program I use is:
-------------------------------------------------------------------------------------------------------------------------------------------------------------
Sub SaveXlRangeToWordFile()

Dim ObjPic As Object, Ws As Worksheet
Dim WdDoc As Object, WdApp As Object

'open Word application
On Error Resume Next
Set WdApp = GetObject(, "word.application")
If Err.Number <> 0 Then
On Error GoTo 0
Set WdApp = CreateObject("Word.Application")
End If

'open doc **********change file path to suit
On Error GoTo erfix
Set WdDoc = WdApp.Documents.Open(Filename:="C:\Users\******\********\******\test.docx")
For Each Ws In ActiveWorkbook.Worksheets
Application.StatusBar = "Copying data from " & Ws.Name & "sheets"

Ws.UsedRange.Copy '

WdDoc.Paragraphs(WdDoc.Paragraphs.Count).Range.PasteSpecial DataType:=3 '9 '4
Application.CutCopyMode = False
WdDoc.Paragraphs(WdDoc.Paragraphs.Count).Range.InsertParagraphAfter

If Not Ws.Name = Worksheets(Worksheets.Count).Name Then

With WdDoc.Paragraphs(WdDoc.Paragraphs.Count).Range
.InsertParagraphAfter
.Collapse Direction:=0 'wdCollapseEnd
.InsertBreak Type:=7 'wdPageBreak
End With
End If
Next Ws

'pictures in newxl version are converted to inlineshapes
'takes time to paste and convert
'Application.Wait (Now + TimeValue("0:00:02"))
'For Each ObjPic In WdApp.ActiveDocument.InlineShapes
'ObjPic.ConvertToShape
'Next ObjPic
WdApp.ActiveDocument.Close savechanges:=True
Set WdDoc = Nothing
WdApp.Quit
Set WdApp = Nothing
Application.StatusBar = False
'Set ObjPic = Nothing
Exit Sub

erfix:
On Error GoTo 0
MsgBox "Save SaveXlRangeToWordFile error"
WdApp.ActiveDocument.Close savechanges:=False
Set WdDoc = Nothing
WdApp.Quit
Set WdApp = Nothing
Application.CutCopyMode = False
Application.StatusBar = False
'Set ObjPic = Nothing
End Sub
----------------------------------------------------------------------------------------------------------------------------------
Can someone maybe help me with the program to autofit the picture to word?

Thanks
 

Excel Facts

What do {} around a formula in the formula bar mean?
{Formula} means the formula was entered using Ctrl+Shift+Enter signifying an old-style array formula.

NdNoviceHlp

Well-known Member
Joined
Nov 9, 2002
Messages
3,187
Hi Diag and Welcome to the Board. See this thread re. addition of page setup etc. HTH. Dave
 

Diag

New Member
Joined
Aug 24, 2022
Messages
5
Office Version
  1. 365
Platform
  1. Windows
Hi Diag and Welcome to the Board. See this thread re. addition of page setup etc. HTH. Dave

Hi Dave Thanks for your reply,

I worked on the code you send and it works. The only thing is that the bottom of my sheet is cut off in the picture when it is loaded in word. The last 5 cm is missing. The width is ok.
Is there a possibility to zoom or autofit the picture in word? The range (A1:O58) I need to work with is fixed. the sheets are generated by a macro provided by the manufacturer of a measurement device.

thanks in advance,

Regards Frans
 

NdNoviceHlp

Well-known Member
Joined
Nov 9, 2002
Messages
3,187
Hi Frans. You can trial setting the scaleheight. Adjust the 0.85 to whatever number works (.085 is 85% of original height). Dave
Code:
'size range pic to sheet
With WdDoc.Shapes(Cnt)
.LockAspectRatio = msoFalse
.Width = WidthAvail
.ScaleHeight 0.85, False
End With]/code]
 
Solution

Diag

New Member
Joined
Aug 24, 2022
Messages
5
Office Version
  1. 365
Platform
  1. Windows
Hi Dave,

I did the test and it works great,
thanks!!!!
 

Forum statistics

Threads
1,182,103
Messages
5,933,660
Members
436,904
Latest member
DangerKennedy

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