VBA Word - Loop - Copy All Charts Word to PowerPoint

[Bebob]

System: Microsoft Windows. Word and PPT 2016.

Hi all,

I've started trying out VBA a few weeks ago and I'm amazed by the possibilities. However, I got stuck in my current project.

My goal is:

Loop through a full word document
Copy the the charts
Paste this charts, each on a different slide in Powerpoint
Additional amendments such as resizing etc. (solved)

At one point: create a box that will ask for the page range.. Although I want to try it out on my own first, suggestions are welcome. Learning by doing ;)



Due to all the helpful information (Peltier is awesome :ipray:) in the web and much trial-and-error my current state is:

The code recognises all charts on the very first page of my word document
Pastes them all on one slide in PowerPoint

Recognises if no chart is in the document
Creates a PPT if none is active



I tried a lot with trial and error ( :type :thinking: ) and found many materials on Excel to PowerPoint. However, the solutions provided there didn't appear to work in Word (different objects? etc.).

My Code is posted below, perhaps you got an idea on my two main problems:

Only recognises the charts on the first page of my document.
Pastes all charts on one slide.





Sub AllWordChartsToPowerPoint()
'Uses the active word document
'Searches for the first chart\ in the document 'Pastes it as chart in a word document


Dim pptApp As Object ' PowerPoint.Application
Dim pptPres As Object ' PowerPoint.Presentation
Dim pptSlide As Object ' PowerPoint.Slide
Dim pptShape As Object ' PowerPoint.Shape
Dim pptShpRng As Object ' PowerPoint.ShapeRange


Dim wdDoc As Document 'Word.Document
Dim wdApp As Word.Application
Dim cht As Object
Dim InShp As InlineShape




'Error handling, for chart-free word documents .
If ActiveDocument.InlineShapes.Count = 0 Then
MsgBox "There are no charts in this Word Document!"
Exit Sub
End If


' Start Loop
For Each Chart In ActiveDocument.InlineShapes


'Copy Chart
Chart.Select
Chart.Range.Copy

' figure out what slide to paste on
On Error Resume Next
Set pptApp = GetObject(, "PowerPoint.Application")
On Error Resume Next


If pptApp Is Nothing Then
Set pptApp = CreateObject("PowerPoint.Application")
Set pptPres = pptApp.Presentations.Add
Set pptSlide = pptPres.Slides.Add(1, 12) ' 12=ppLayoutBlank
Else
If pptApp.Presentations.Count > 0 Then
Set pptPres = pptApp.ActivePresentation
If pptPres.Slides.Count > 0 Then
lActiveSlideNo = pptApp.ActiveWindow.View.Slide.SlideIndex
Set pptSlide = pptPres.Slides(lActiveSlideNo)
Else
Set pptSlide = pptPres.Slides.Add(1, 12) ' 12=ppLayoutBlank
End If
Else
Set pptPres = pptApp.Presentations.Add
Set pptSlide = pptPres.Slides.Add(1, 12) ' 12=ppLayoutBlank
End If
End If


' paste chart
With pptSlide
.Shapes.Paste
Set pptShape = .Shapes(.Shapes.Count)
Set pptShpRng = .Shapes.Range(pptShape.Name)

End With


' align shape on slide
With pptShpRng
.Top = 10
.Height = 300
.Left = 10
.Width = 600
.Align msoAlignCenters, True ' left-right
.Align msoAlignMiddles, True ' top-bottom

End With

'Restart loop
Next


End Sub

[Bebob]

Update:

I managed to solve the problem of pasting one chart on a single slide at a time :cool:

Adding a counter in the If .. Then clauses solved this.

Now I just need to figure out how to get actually every Chart within the Word document and not just the charts on the first page.

Best,
Bebob




If pptApp Is Nothing Then
Set pptApp = CreateObject("PowerPoint.Application")
Set pptPres = pptApp.Presentations.Add
Set pptSlide = pptPres.Slides.Add(1, 12) ' 12=ppLayoutBlank
Else
If pptApp.Presentations.Count > 0 Then
Set pptPres = pptApp.ActivePresentation
If pptPres.Slides.Count > 0 Then
Set pptSlide = pptPres.Slides.Add(pptPres.Slides.Count + 1, 12) ' 12=ppLayoutBlank
Else
Set pptSlide = pptPres.Slides.Add(pptPres.Slides.Count + 1, 12) ' 12=ppLayoutBlank
End If
Else
Set pptPres = pptApp.Presentations.Add
Set pptSlide = pptPres.Slides.Add(1, 12) ' 12=ppLayoutBlank
End If

End If