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

Nagoo

New Member
Joined
Jul 2, 2015
Messages
25
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(n).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(n).Width
MyChart.ChartArea.Height = ActiveSheet.Shapes(n).Height
MyChart.Parent.Border.LineStyle = 0 'remove shape container border

'copy picture
ActiveSheet.Shapes(n).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
 

Excel Facts

Convert text numbers to real numbers
Select a column containing text numbers. Press Alt+D E F to quickly convert text to numbers. Faster than "Convert to Number"

Jon Peltier

MrExcel MVP
Joined
May 14, 2003
Messages
4,966
Office Version
  1. 365
Platform
  1. Windows
  2. MacOS
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?
 

Watch MrExcel Video

Forum statistics

Threads
1,133,268
Messages
5,657,742
Members
418,411
Latest member
Excellency

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