I want to export all charts, as pictures, from an Excel file to a Word document, one following the previous one. However the pictures are kept pasted on top of the previous one so I only have the last picture in the Word document. I would also need to have the pictures centered through the Excel macro, if feasible.
Sub ExportChartsToWord()
' Declare variables
Dim WdApp As Object
Dim WdDoc As Object
Dim Ws As Worksheet
Dim chrt As ChartObject
Dim chrtName As String
Dim i As Integer
' Initialize Word application
Set WdApp = CreateObject("Word.Application")
WdApp.Visible = True
Set WdDoc = WdApp.Documents.Add
File = "E:\Documents - Misc\Charts to Word.docx"
'Word session creation
'word will be closed while running
' WordApp.Visible = False
'open the .doc file
Set WdDoc = WdApp.Documents.Open(File)
'Loop through each worksheet
For Each Ws In ThisWorkbook.Worksheets
'Loop through each chart in the worksheet
For Each chrt In Ws.ChartObjects
' Copy the chart
chrt.Chart.CopyPicture Appearance:=xlScreen, Format:=xlPicture
' Paste the chart into Word
WdDoc.Content.InsertAfter ""
'Selection.TypeParagraph
'Selection.MoveDown Unit:=wdLine, Count:=3
WdDoc.Content.PasteAndFormat (wdFormatOriginalFormatting)
WdDoc.Content.ParagraphFormat.Alignment = wdAlignParagraphCenter
WdDoc.Range.ParagraphFormat.Alignment = wdAlignParagraphCenter
'WdDoc.Content.Alignment = wdAlignCenter
'Selection.TypeParagraph
'Add a new page after each chart
WdDoc.Content.InsertParagraphAfter
WdDoc.Content.ParagraphFormat.SpaceAfter = 6
WdDoc.Content.ParagraphFormat.SpaceBeforeAuto = True
' Loop through all inline shapes (images) in the document
'wdDoc.Content.MoveDown
'wdDoc.Selection.MoveDown Unit:=wdLine, Count:=2
'wdDoc.Content.TypeParagraph
'wdDoc.Selection.Find.Execute Replace:=2
'wdDoc.Selection.Expand wdParagraph
'wdDoc.Selection.InlineShapes(1).Select
'wdDoc.Selection.InsertParagraphAfter
Next chrt
Next Ws
' Save the Word document
WdDoc.SaveAs2 "E:\Documents - Misc\Charts to Word.docx"
' Clean up
'wdDoc.Close
'wdApp.Quit
'Set wdDoc = Nothing
'Set wdApp = Nothing
MsgBox "Charts exported successfully!"
End Sub
Excel file:
Word Document:
Answer
Alternative approach avoiding the clipboard:
Sub ExportChartsToWord()
Dim WdApp As Object
Dim WdDoc As Object
Dim Ws As Worksheet
Dim chrt As ChartObject, tmpPath As String
Set WdApp = GetObject(, "Word.Application") 'using open Word instance...
WdApp.Visible = True
Set WdDoc = WdApp.Documents.Add
For Each Ws In ThisWorkbook.Worksheets
For Each chrt In Ws.ChartObjects
tmpPath = tempPath() 'get a save path
chrt.Chart.Export tmpPath, "PNG"
WdDoc.Range.InlineShapes.AddPicture Filename:=tmpPath, _
LinkToFile:=False, SaveWithDocument:=True
Next chrt
Next Ws
End Sub
'return a temporary file path
Function tempPath() As String
With CreateObject("scripting.filesystemobject")
tempPath = .BuildPath(.GetSpecialFolder(2), .GetTempName())
End With
End Function
