PAsting Excel cahrts as pictures into PowerPoint: changing the propotions width/heigh

  • Thread starter Thread starter mbobro
  • Start date Start date
M

mbobro

Dear all,

I do prepare a program that will produce PowerPoints
reports/presentations out of prepared Excel data and Excel charts. As
there is no need to edit data in PowerPoint presentation I decided to
get rid of troubles with MS Graph and embembed Excel charts and paste
the Excel charts as pictures.

Below I put the code, modyficated version of an idea found in the
Internet (many thanks to the author). The trouble is that when I try to
adjust the picture to the size I need it fits the height while ignoring
the widht. I feel it is a case of keeping the original proportions
between widht and height from Excel.

Of course I may make the Excel to make the charts 'to be pictured'
afterwards in the exactly same size I use them afterwards in
PowerPoint, but maybe you friends have a better option?

Regards,


Michal


Sub navigator()

ChartsToPresentation PasteSlideNumber:=2
ShapePosition _
PositionLeft:=48.375, _
PositionTop:=258.125, _
pWidth:=390.25, _
pHeight:=195

End Sub

Sub ChartsToPresentation(PasteSlideNumber As Byte)
' Set a VBE reference to Microsoft PowerPoint 8.0 Object Library for
Office 97,
' or Microsoft PowerPoint 9.0 Object Library for Office 2000.
' NOTE: I have only tested this in Office 97.


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 97
Set PPApp = GetObject(, "Powerpoint.Application.10")
' 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)
PPPres.Slides(PasteSlideNumber).Select
PPApp.ActiveWindow.View.GotoSlide Index:=PasteSlideNumber
'PPSlide.SlideIndex 'PasteSlideNumber
With PPSlide
' paste and select the chart picture
PPPres.Slides(PasteSlideNumber).Shapes.Paste.Select
' align the chart
PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters,
True
PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles,
True
End With

Next

End Sub


Sub ShapePosition(PositionLeft As Single, PositionTop As Single, pWidth
As Single, pHeight As Single)


With PPApp.ActiveWindow.Selection.ShapeRange
..Left = PositionLeft
..Top = PositionTop
..Width = pWidth
..Height = pHeight
End With

' Clean up
Set PPSlide = Nothing
Set PPPres = Nothing
Set PPApp = Nothing


End Sub
 
Michal,
Instead of setting the width and height properties with hard coded
numbers, just scale them equally. The following scales the selected
shaperange to 100% of it's original height and width.

With ActiveWindow.Selection.ShapeRange
.ScaleHeight 1, True
.ScaleWidth 1, True
End With

Brian Reilly, PowerPoint MVP
 
Back
Top