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

Copy formula down without changing references
If you have =SUM(F2:F49) in F50; type Alt+' in F51 to copy =SUM(F2:F49) to F51, leaving the formula in edit mode. Change SUM to COUNT.

Jon Peltier

MrExcel MVP
Joined
May 14, 2003
Messages
5,244
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?
 
Master Excel Bundle

Excel contains over 450 functions, with more added every year. That’s a huge number, so where should you start? Right here with this bundle.

Forum statistics

Threads
1,167,771
Messages
5,855,579
Members
431,744
Latest member
Djarvis37

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