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