Maybe this site can give some help:
http://office.microsoft.com/en-us/po...045551033.aspx
"kimbobo" wrote:
> I am using some code I got from a friend and it only appears to work
> for embedded chart objects? I would like it to work for Charts that
> are in the Chart Sheet format.
>
> Any Suggestions?
>
> Thanks!
>
> Sub Charts_To_Presentation()
>
> '''''''''''''''''''''''''''''''''''''''''''''''''''''
> ' This macro copies each chart in Excel and pastes it
> ' as a picture in PowerPoint
> '''''''''''''''''''''''''''''''''''''''''''''''''''''
>
> Dim oPowerPoint As New PowerPoint.Application
> Dim appPPT As PowerPoint.Application
> Dim pptPres As Presentation
> Dim pptSlide As Slide
> Dim appXL As Excel.Application
> Dim ws As Worksheet
> Dim ch As Chart
> Dim aChtObj As ChartObject
> Dim wkb As Workbook
> Dim SlideCount As Long
> Dim CurrentSheetName As String
>
>
> ''''''''''''''''''''''''''''''''''''''''''''''''''
> ' Creates a new Presentation and adds title slide
> ''''''''''''''''''''''''''''''''''''''''''''''''''
>
> 'Set pptPres = oPowerPoint.Presentations.Add
>
> 'With pptPres.Slides
> ' Set pptSlide = .Add(.Count + 1, ppLayoutTitleOnly)
> ' pptSlide.Shapes.Title.TextFrame.TextRange.Text = "XXX Survey"
> 'End With
>
> ''''''''''''''''''''''''''''''''''''''''''''
> ' Reference existing instance of PowerPoint
> ''''''''''''''''''''''''''''''''''''''''''''
>
> Set appPPT = GetObject(, "Powerpoint.Application")
> 'Reference active presentation
> Set pptPres = appPPT.ActivePresentation
> appPPT.ActiveWindow.ViewType = ppViewSlide
>
> '''''''''''''''''''''''''''''''''''''''
> 'Places each embedded chart in a slide
> '''''''''''''''''''''''''''''''''''''''
>
> For Each ws In ActiveWorkbook.Worksheets
> CurrentSheetName = ws.Name
> For Each aChtObj In ws.ChartObjects
>
> ''''''''''''''''''''''''
> 'copies chart
> ''''''''''''''''''''''''
>
> aChtObj.Copy
>
> ''''''''''''''''''''''''''''''''''''''
> 'Adds a new slide and pastes the chart
> ''''''''''''''''''''''''''''''''''''''
>
> SlideCount = pptPres.Slides.Count
> Set pptSlide = pptPres.Slides.Add(SlideCount + 1, ppLayoutBlank)
> appPPT.ActiveWindow.View.GotoSlide pptSlide.SlideIndex
>
> pptSlide.Shapes.PasteSpecial(ppPasteMetafilePicture).Select
> 'centers the chart
> appPPT.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters,
> msoTrue
> appPPT.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles,
> msoTrue
>
>
>
> ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
> ' Creates a text box and pastes the Excel sheet's name in it
> ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
>
> appPPT.ActiveWindow.Selection.SlideRange.Shapes.AddTextbox(msoTextOrientationHorizontal,
> 5, 10, 625, 27).Select
> appPPT.ActiveWindow.Selection.TextRange.ParagraphFormat.Alignment =
> ppAlignLeft
> appPPT.ActiveWindow.Selection.ShapeRange.TextFrame.TextRange.Characters(Start:=1,
> Length:=0).Select
> With appPPT.ActiveWindow.Selection.TextRange
>
> .Text = CurrentSheetName
> With .Font
> .Name = "Arial"
> .Size = 28
> .Bold = msoFalse
> End With
> End With
>
> ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
> ' Creates a text box for the take-away
> ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
>
> appPPT.ActiveWindow.Selection.SlideRange.Shapes.AddTextbox(msoTextOrientationHorizontal,
> 38, 67, 652, 27).Select
> appPPT.ActiveWindow.Selection.ShapeRange.TextFrame.TextRange.Paragraphs(Start:=1,
> Length:=1).ParagraphFormat.Bullet.Visible = msoFalse
> appPPT.ActiveWindow.Selection.TextRange.ParagraphFormat.Alignment =
> ppAlignLeft
> appPPT.ActiveWindow.Selection.ShapeRange.TextFrame.TextRange.Characters(Start:=1,
> Length:=0).Select
> With appPPT.ActiveWindow.Selection.TextRange
>
> .Text = "XXX"
> With .Font
> .Name = "Arial"
> .Size = 20
> .Bold = msoTrue
> .Color.RGB = RGB(Red:=26, Green:=117, Blue:=206)
> End With
> End With
>
> Next aChtObj
> Next ws
>
> End Sub
>
>
Similar Threads
