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 ) 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 ( ) 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

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