B
Bo
Hi all,
Have a problem with picture resolution when copying excel charts to
PowerPoint.
The code below (compiled from internet) works but generates bad resolution
when invoked from button in excel. If I run the code manually (step by step)
the first slide comes out great, but with the second slide I get an
automation when resizing the image.
Any suggestions?
Thanks Bo
#### VBA
Sub CTP()
Dim ChartName As Variant
Dim PPApp As PowerPoint.Application
Dim PPPres As PowerPoint.Presentation
Dim PPSlide As PowerPoint.Slide
Dim PresentationFileName As Variant
Dim CurrentTitle As Variant
Dim SlideCount As Long
Dim ch As Chart
Set PPApp = CreateObject("Powerpoint.Application")
Set PPPres = PPApp.Presentations.Add
PPApp.Visible = msoTrue
CurrentTitle = "Testing"
PresentationFileName = PPApp.ActivePresentation.Path
PresentationFileName = PresentationFileName & CurrentTitle & ".ppt"
For Each ch In ActiveWorkbook.Charts
ch.Activate
ch.CopyPicture xlScreen, xlPicture, xlScreen
SlideCount = PPPres.Slides.Count
Set PPSlide = PPPres.Slides.Add(SlideCount + 1, ppLayoutBlank)
With PPSlide
.Shapes.Paste.Select
'resize image
PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters,
True
PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles,
True
PPApp.ActiveWindow.Selection.ShapeRange.Height = 505.88
PPApp.ActiveWindow.Selection.ShapeRange.Width = 720
PPApp.ActiveWindow.Selection.ShapeRange.Left = 0
PPApp.ActiveWindow.Selection.ShapeRange.Top = 17
PPApp.ActiveWindow.Selection.Unselect
End With
SlideCount = SlideCount + 1
Next
With PPPres
' .SaveAs "C:\test.ppt"
.Close
End With
PPApp.Quit
Set PPApp = Nothing
Set PPPres = Nothing
End Sub
####
Have a problem with picture resolution when copying excel charts to
PowerPoint.
The code below (compiled from internet) works but generates bad resolution
when invoked from button in excel. If I run the code manually (step by step)
the first slide comes out great, but with the second slide I get an
automation when resizing the image.
Any suggestions?
Thanks Bo
#### VBA
Sub CTP()
Dim ChartName As Variant
Dim PPApp As PowerPoint.Application
Dim PPPres As PowerPoint.Presentation
Dim PPSlide As PowerPoint.Slide
Dim PresentationFileName As Variant
Dim CurrentTitle As Variant
Dim SlideCount As Long
Dim ch As Chart
Set PPApp = CreateObject("Powerpoint.Application")
Set PPPres = PPApp.Presentations.Add
PPApp.Visible = msoTrue
CurrentTitle = "Testing"
PresentationFileName = PPApp.ActivePresentation.Path
PresentationFileName = PresentationFileName & CurrentTitle & ".ppt"
For Each ch In ActiveWorkbook.Charts
ch.Activate
ch.CopyPicture xlScreen, xlPicture, xlScreen
SlideCount = PPPres.Slides.Count
Set PPSlide = PPPres.Slides.Add(SlideCount + 1, ppLayoutBlank)
With PPSlide
.Shapes.Paste.Select
'resize image
PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters,
True
PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles,
True
PPApp.ActiveWindow.Selection.ShapeRange.Height = 505.88
PPApp.ActiveWindow.Selection.ShapeRange.Width = 720
PPApp.ActiveWindow.Selection.ShapeRange.Left = 0
PPApp.ActiveWindow.Selection.ShapeRange.Top = 17
PPApp.ActiveWindow.Selection.Unselect
End With
SlideCount = SlideCount + 1
Next
With PPPres
' .SaveAs "C:\test.ppt"
.Close
End With
PPApp.Quit
Set PPApp = Nothing
Set PPPres = Nothing
End Sub
####