Messy alignment when copying to Power Point
Hello
I am trying to build a script that will move through a number of sheets, select the charts on them an copy them into a blank PP presentation. It works fine except for one detail. The alignment when pasting the charts only seems to function for the charts lifted from the first of my excel-sheets. The script is based on a script by peltier inc. My sub looks like this:
[vba]Sub ChartsToPresentation()
' Set a VBE reference to Microsoft PowerPoint Object Library
Dim PPApp As PowerPoint.Application
Dim PPPres As PowerPoint.Presentation
Dim PPSlide As PowerPoint.Slide
Dim PresentationFileName As Variant
Dim SlideCount As Long
Dim iCht As Integer
' Reference existing instance of PowerPoint
Set PPApp = GetObject(, "Powerpoint.Application")
' Reference active presentation
Set PPPres = PPApp.ActivePresentation
PPApp.ActiveWindow.ViewType = ppViewSlide
For iCht = 1 To ActiveSheet.ChartObjects.Count
' copy chart as a picture
ActiveSheet.ChartObjects(iCht).Chart.CopyPicture _
Appearance:=xlScreen, Size:=xlScreen, Format:=xlPicture
' Add a new slide and paste in the chart
SlideCount = PPPres.Slides.Count
Set PPSlide = PPPres.Slides.Add(SlideCount + 1, ppLayoutBlank)
PPApp.ActiveWindow.View.GotoSlide PPSlide.SlideIndex
With PPSlide
' paste and select the chart picture
.Shapes.Paste.Select
' align the chart
PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True ' The only working alignements
PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True
End With
Sheets("Indeksdiff...").Activate ' Next sheet
If iCht <= ActiveSheet.ChartObjects.Count Then
ActiveSheet.ChartObjects(iCht).Chart.CopyPicture _
Appearance:=xlScreen, Size:=xlScreen, Format:=xlPicture 'Kopier figur
PPApp.ActiveWindow.View.GotoSlide PPSlide.SlideIndex
With PPSlide
.Shapes.Paste.Select 'Indsæt og vælg difference-figur
PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignRights, True
PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddels, True ' This doesnt work
End With
End If
If iCht <= Sheets("Hvor ofte...").ChartObjects.Count Then
Sheets("Hvor ofte...").Activate 'Gå til Hvor ofte
ActiveSheet.ChartObjects(iCht).Chart.CopyPicture _
Appearance:=xlScreen, Size:=xlScreen, Format:=xlPicture 'Kopier figur
SlideCount = PPPres.Slides.Count
Set PPSlide = PPPres.Slides.Add(SlideCount + 1, ppLayoutBlank)
PPApp.ActiveWindow.View.GotoSlide PPSlide.SlideIndex
With PPSlide
.Shapes.Paste.Select 'Indsæt og vælg Hvor ofte-figur
PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddels, True ' Placer figuren rigtigt
End With
Set PPSlide = PPPres.Slides.Add(SlideCount + 1, ppLayoutBlank)
End If
If iCht <= Sheets("Hvorfor...").ChartObjects.Count Then
Sheets("Hvorfor...").Activate 'Gå til Hvorfor
ActiveSheet.ChartObjects(iCht).Chart.CopyPicture _
Appearance:=xlScreen, Size:=xlScreen, Format:=xlPicture 'Kopier figur
SlideCount = PPPres.Slides.Count
Set PPSlide = PPPres.Slides.Add(SlideCount + 1, ppLayoutBlank)
PPApp.ActiveWindow.View.GotoSlide PPSlide.SlideIndex
With PPSlide
.Shapes.Paste.Select 'Indsæt og vælg hvorfor-figur
PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddels, True ' Placer figuren rigtigt
End With
Set PPSlide = PPPres.Slides.Add(SlideCount + 1, ppLayoutBlank)
End If
Sheets("Hvor høj grad....").Activate
Next
' Clean up
Set PPSlide = Nothing
Set PPPres = Nothing
Set PPApp = Nothing
End Sub
[/vba]
I suspect the issue is connected to activating the right power-point slide, but I can't figure out how, or if this is indeed the issue. Furthermore I also have som tabels in antoher sheet of my excel file that I would like to copy in the same fashion. Any pointers on both of these issues would be greatly appriciated. Thank you
Reply With Quote