Consulting

Results 1 to 4 of 4

Thread: Excel VBA code to export charts to PowerPoint as metafile

  1. #1
    VBAX Newbie
    Joined
    Aug 2015
    Posts
    2
    Location

    Excel VBA code to export charts to PowerPoint as metafile

    Writing Excel VBA (Office 2010) code to launch an existing PPT template and paste in an Excel generated chart as a metafile. Can't get the pasting to work. Here's what I have so far.

    Dim PPT As PowerPoint.Application
    Dim pptPres1 As PowerPoint.Presentation


    Set PPT = New PowerPoint.Application
    PPT.Visible = True
    PPT.Presentations.Open Filename:="C:\template.pptx"
    Set pptPres1 = PPT.ActivePresentation


    'copy first bar chart from Excel
    ActiveSheet.ChartObjects("Chart 1").Activate
    ActiveChart.ChartArea.Copy


    Appreciate any help. Thanks.

  2. #2
    Knowledge Base Approver VBAX Wizard p45cal's Avatar
    Joined
    Oct 2005
    Location
    Surrey UK
    Posts
    5,844
    ActiveSheet.ChartObjects("Chart 1").Chart.CopyPicture
    pptPres1.Slides(2).Shapes.PasteSpecial ppPasteEnhancedMetafile
    ?
    p45cal
    Everyone: If I've helped and you can't be bothered to acknowledge it, I can't be bothered to look at further posts from you.

  3. #3
    VBAX Newbie
    Joined
    Aug 2015
    Posts
    2
    Location
    Seems to work. Thanks for the help!

  4. #4
    Hi anyone can help me to debug the error? I have tried for few weeks but notable to figure out why.
    The function of macro in this file is used to copy the chart from excel to presentation slides. I saved the presentation slides template at desktop and copy the link to the excel macro file.
    When running the 1st time macro, it's able to works well. After close the presentation file and re-run again the macro, the error message prompted said run time error. I have no idea how to debug the error. Hope anyone can help me?


    Sub Xls2Ppt()
    Dim objPPT As Object
    Dim Shapes As Object


    Dim pptApp As Object
    Dim pptPres As Object
    Dim pptSlide As Object
    Dim pptShape As Object


    Dim MacroFile As String
    Dim strTemplate As String
    Dim strSheet As String
    Dim strTitle As String


    Dim intTotalSlide As Integer
    Dim i As Integer
    Dim j As Integer


    Dim SlideCount As Long


    MacroFile = ActiveWorkbook.Name
    strTemplate = Range("C4")
    strSheet = Range("C5")
    intTotalSlide = LastRow - 5


    Set objPPT = CreateObject("PowerPoint.Application")
    objPPT.Visible = True
    objPPT.Presentations.Open strTemplate


    Set pptApp = GetObject(, "Powerpoint.Application")
    Set pptPres = pptApp.ActivePresentation
    pptApp.ActiveWindow.ViewType = ppViewSlide

    j = pptPres.Slides.Count 'count slides
    j = 2
    i = 6

    Windows(MacroFile).Activate
    Sheets("Macro").Select
    strSheet = Range("C" & i)
    strTitle = Range("D" & i)
    Sheets(strSheet).Select


    ' 1st slide- Q1
    '********************************
    Windows(MacroFile).Activate
    Sheets("Macro").Select
    strSheet = Range("C" & i)
    strTitle = Range("D" & i)
    Sheets(strSheet).Select
    '*********************************


    'Copy Q1
    'Range("D3", "L" & Sheet6.Range("F65536").End(xlUp).Row).Select
    Range("D2:K24").Select
    Selection.Copy

    SlideCount = pptPres.Slides.Count
    Set pptSlide = pptPres.Slides.Add(j, ppLayoutTitleOnly)
    pptApp.ActiveWindow.View.GotoSlide pptSlide.SlideIndex
    pptSlide.Shapes.PasteSpecial ppPasteBitmap

    With pptSlide
    .Shapes(1).TextFrame.TextRange.Text = strTitle
    End With

    pptSlide.Shapes(pptSlide.Shapes.Count).Select
    Set sr = pptApp.ActiveWindow.Selection.ShapeRange
    sr.Align msoAlignMiddles, True
    pptApp.ActiveWindow.Selection.ShapeRange.Top = 120

    sr.ScaleHeight 0.9, msoTrue
    sr.ScaleWidth 0.9, msoTrue

    sr.Left = 120



    '2nd slide - Q2
    '************************************
    j = j + 1
    i = i + 1
    Windows(MacroFile).Activate
    Sheets("Macro").Select
    strSheet = Range("C" & i)
    strTitle = Range("D" & i)
    Sheets(strSheet).Select
    '*************************************



    'Copy Q2
    'Range("D3", "L" & Sheet6.Range("F65536").End(xlUp).Row).Select
    Range("D28:K49").Select
    Selection.Copy

    SlideCount = pptPres.Slides.Count
    Set pptSlide = pptPres.Slides.Add(j, ppLayoutTitleOnly)
    pptApp.ActiveWindow.View.GotoSlide pptSlide.SlideIndex
    pptSlide.Shapes.PasteSpecial ppPasteBitmap

    With pptSlide
    .Shapes(1).TextFrame.TextRange.Text = strTitle
    End With

    pptSlide.Shapes(pptSlide.Shapes.Count).Select
    Set sr = pptApp.ActiveWindow.Selection.ShapeRange
    sr.Align msoAlignMiddles, True
    pptApp.ActiveWindow.Selection.ShapeRange.Top = 120

    sr.ScaleHeight 0.9, msoTrue
    sr.ScaleWidth 0.9, msoTrue

    sr.Left = 120


    '3 slide - Q3
    '************************************
    j = j + 1
    i = i + 1
    Windows(MacroFile).Activate
    Sheets("Macro").Select
    strSheet = Range("C" & i)
    strTitle = Range("D" & i)
    Sheets(strSheet).Select
    '*************************************



    'Copy Q3
    'Range("D3", "L" & Sheet6.Range("F65536").End(xlUp).Row).Select
    Range("D55:K76").Select
    Selection.Copy

    SlideCount = pptPres.Slides.Count
    Set pptSlide = pptPres.Slides.Add(j, ppLayoutTitleOnly)
    pptApp.ActiveWindow.View.GotoSlide pptSlide.SlideIndex
    pptSlide.Shapes.PasteSpecial ppPasteBitmap

    With pptSlide
    .Shapes(1).TextFrame.TextRange.Text = strTitle
    End With

    pptSlide.Shapes(pptSlide.Shapes.Count).Select
    Set sr = pptApp.ActiveWindow.Selection.ShapeRange
    sr.Align msoAlignMiddles, True
    pptApp.ActiveWindow.Selection.ShapeRange.Top = 120

    sr.ScaleHeight 0.9, msoTrue
    sr.ScaleWidth 0.9, msoTrue

    sr.Left = 120



    End




    End Sub




    Attached the original excel file with macro coding. Thank you very much.
    Attached Images Attached Images
    Attached Files Attached Files

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •