VBA code to copy multiple high resolution images from excel and paste to word

[Nagoo]

Hello I checked multiple links in Me.Excel before posting this thread.

I am trying to copy multiple images with high resolution from a sheet named 'Image paster' to a word doc wich is linked to a path. The images are not getting pasted due to high resolution since i used chart method. Could any one of you suggest a better way to copy multiple images of high resolution from a sheet to a word doc? It would be of great help

my code is as below:

Dim wrdApp As Word.Application
Dim wrdDoc As Word.Document
Dim filepath As String

Set wrdApp = CreateObject("Word.Application")

wrdApp.Visible = True

filepath = "C:/Hello/Exercise.doc"

Set wrdDoc = wrdApp.Documents.Open(filepath)

wrdApp.ActiveDocument.Content.Delete

wrdApp.Selection.TypeParagraph



wrdApp.ActiveDocument.Bookmarks.Add Name:="Placeholder"

wrdApp.Selection.TypeParagraph
wrdApp.Selection.TypeParagraph

wrdApp.ActiveDocument.Bookmarks.Add Name:="Image"

wrdApp.ActiveDocument.Bookmarks("Image").Select

'wrdApp.ActiveDocument.Bookmarks.Add Name:="XXX"

Dim MyChart As Chart
Dim n As Long, shCount As Long
Dim pictureNumber As Integer


Sheets("Image_Paster").Select
pictureNumber = 1

shCount = ActiveSheet.Shapes.Count
If Not shCount = 0 Then


For n = 1 To shCount
If InStr(ActiveSheet.Shapes.Name, "Picture") > 0 Then
'create chart as a canvas for saving this picture
Set MyChart = Charts.Add
MyChart.Name = "TemporaryPictureChart"
'move chart to the sheet where the picture is
Set MyChart = MyChart.Location(Where:=xlLocationAsObject, Name:="Image_Paster")

'resize chart to picture size
MyChart.ChartArea.Width = ActiveSheet.Shapes.Width
MyChart.ChartArea.Height = ActiveSheet.Shapes.Height
MyChart.Parent.Border.LineStyle = 0 'remove shape container border

'copy picture
ActiveSheet.Shapes.Copy

'paste picture into chart
MyChart.ChartArea.Select
MyChart.Paste

MyChart.CopyPicture
wrdApp.Selection.Paste
wrdApp.Selection.MoveRight unit:=wdCharacter, Count:=1
wrdApp.Selection.TypeParagraph
wrdApp.Selection.TypeParagraph
Application.CutCopyMode = False

pictureNumber = pictureNumber + 1

'delete chart
ActiveSheet.Cells(1, 1).Activate
ActiveSheet.ChartObjects(ActiveSheet.ChartObjects.Count).Delete
End If
Next
End If

 

[Jon Peltier]

I don't see why you need to use a chart as an intermediate here. What if you just copy each shape and paste it into Word?