Results 1 to 4 of 4

Thread: Embed an Excel Chart into PowerPoint - VBA

  1. #1
    Junior Member
    Join Date
    May 2012
    Posts
    25
    Rep Power
    0

    Question Embed an Excel Chart into PowerPoint - VBA

    Hi,
    I am trying to copy a ChartObject created in a workbook sheet and paste it into a powerpoint 2010 slide, such that it becomes a standalone Excel Chart with data (embedded).

    When i do it manually i.e :

    1. Copy ChartObject present in WorkSheet
    2. Goto Powerpoint Slide
    3. Click PasteSpecial & select "Use Destination Theme & Embed Workbook (H)".
    4. Right-click the ChartObject in Powerpoint & click "Edit Data".


    Then i get a new standalone workbook with Title "Chart in Microsoft Excel", that shows the Chart as well as data. I have not been able to replicate this scenario where i get a new standalone workbook with Title "Chart in Microsoft Excel" using Excel VBA. Can someone help?

    Assuming there is a simple column chart on the sheet, here is the code:

    PHP Code:
    Option Explicit
    Sub doit
    ()
    Dim Temp As Workbook
    Dim Rng 
    As Range
    Dim ChtObj 
    As ChartObject

    With ThisWorkbook
    .Sheets(1)
        
    Set ChtObj = .ChartObjects(1)
        
    With ChtObj
            
    .Copy
        End With

        Dim ppapp 
    As Object
        Dim pppres 
    As Object
        Dim ppslide 
    As Object

        On Error Resume Next
        Set ppapp 
    GetObject(, "Powerpoint.Application")

        If 
    ppapp Is Nothing Then
            Set ppapp 
    CreateObject("Powerpoint.Application")
        
    End If
        
    On Error GoTo 0

        Set pppres 
    ppapp.presentations.Add
        Set ppslide 
    pppres.Slides.Add(112)

        
    With ppapp
            
    .Activate
            
    .Visible msoTrue
            
    .ActiveWindow.viewtype 1
        End With

        ChtObj
    .Copy
        ppapp
    .ActiveWindow.View.Paste

    End With
    End Sub 
    i have tried :

    PHP Code:
    ppslide.Shapes.PasteSpecial(110, , , , 0'11 = ppPasteShape 
    OR

    PHP Code:
    ppslide.Shapes.PasteSpecial 100, , , , '10 = ppPasteOLEObject 
    OR

    PHP Code:
    ppapp.ActiveWindow.View.PasteSpecial 100, , , , 
    but it did not help!
    Last edited by Junoon; 07-11-2013 at 11:03 PM. Reason: PHP TAGS USED

  2. #2
    Junior Member
    Join Date
    May 2012
    Posts
    25
    Rep Power
    0
    is there anyone who can help me with my issue?

  3. #3
    Administrator Admin's Avatar
    Join Date
    Mar 2011
    Posts
    1,122
    Rep Power
    10
    Hi,

    Try

    In a standard module

    Code:
    Option Explicit
    
    Public wbkNew               As Workbook
    Public WbkName              As String
    
    Sub GetChartData(ByRef Chart_Object As ChartObject)
    
        Dim chtChart            As Chart
        Dim pntPoint            As Point
        Dim lngLoop             As Long
        Dim lngLoopSrs          As Long
        Dim lngSrsCount         As Long
        Dim lngPlotBy           As Long
        Dim lngChartType        As Long
        Dim lngSU               As Long
        Dim lngSecSrsCnt        As Long
        Dim wbkActive           As Workbook
        Dim wksNew              As Worksheet
        Dim varArrYVals()       As String
        Dim strNumFormatHeader  As String
        Dim strNumFormatData    As String
        Dim strNumFormatDataSec As String
        Dim strFmla             As String
        Dim strShtName          As String
        Dim strRange            As String
        Dim strListSep          As String
        Dim strAcell            As String
        Dim blnHasLabel         As Boolean
        Dim blnFlag             As Boolean
        Dim blnSizeStored       As Boolean
        Dim lngArrSecSrs()      As Long
        Dim varArrOutput()      As Variant
        Dim varXVal             As Variant
        Dim varYVal             As Variant
        Dim varVal              As Variant
        Dim varSpltFmla         As Variant
        Dim varSpltRange        As Variant
        
        With Application
            lngSU = .ScreenUpdating
            .ScreenUpdating = False
            .EnableEvents = False
        End With
    
        Set wbkActive = ThisWorkbook
        strAcell = ActiveCell.Address
        
        Set chtChart = Chart_Object.Chart
        lngPlotBy = chtChart.PlotBy
        lngSrsCount = chtChart.SeriesCollection.Count
    
        lngChartType = CLng(chtChart.ChartType)
        
        Select Case lngChartType
    
            Case -4111, 51, 52, 57, 58, 65, 93, 94  'Line,Column,Bar
            
                ReDim varArrOutput(1 To lngSrsCount + 1)
                ReDim varArrYVals(1 To lngSrsCount + 1)
    
                varXVal = chtChart.SeriesCollection(1).XValues
                varArrOutput(1) = varXVal
                varArrYVals(1) = vbNullString
                
                On Error Resume Next
                varYVal = chtChart.Axes(1, 1).CategoryNames
                strNumFormatHeader = chtChart.Axes(1, xlPrimary).TickLabels.NumberFormat
                If strNumFormatHeader = vbNullString Then strNumFormatHeader = "@"
                strNumFormatData = chtChart.Axes(2, xlPrimary).TickLabels.NumberFormat
                strNumFormatDataSec = chtChart.Axes(2, xlSecondary).TickLabels.NumberFormat
                On Error GoTo 0
                
                If strNumFormatDataSec = vbNullString Then blnFlag = True
                
                For lngLoopSrs = 1 To lngSrsCount
                    varVal = chtChart.SeriesCollection(lngLoopSrs).Values
                    If Not blnFlag Then
                        If chtChart.SeriesCollection(lngLoopSrs).AxisGroup = 2 Then
                            lngSecSrsCnt = lngSecSrsCnt + 1
                            ReDim Preserve lngArrSecSrs(1 To lngSecSrsCnt)
                            lngArrSecSrs(lngSecSrsCnt) = lngLoopSrs
                        End If
                    End If
                    varArrOutput(lngLoopSrs + 1) = varVal
                    varArrYVals(lngLoopSrs + 1) = chtChart.SeriesCollection(lngLoopSrs).Name
                Next
                
            Case -4102, 5, 69, 70 'Pie
            
                ReDim varArrOutput(1 To lngSrsCount + 1)
                ReDim varArrYVals(1 To lngSrsCount + 1)
                
                varXVal = chtChart.SeriesCollection(1).XValues
                varArrOutput(1) = varXVal
                varArrYVals(1) = vbNullString
                
                On Error Resume Next
                
                Set pntPoint = chtChart.SeriesCollection(1).Points(1)
                blnHasLabel = pntPoint.HasDataLabel
                
                varYVal = chtChart.Axes(1, 1).CategoryNames
                
                strNumFormatHeader = chtChart.Axes(1, xlPrimary).TickLabels.NumberFormat
                If strNumFormatHeader = vbNullString Then strNumFormatHeader = "@"
                If Not blnHasLabel Then
                    pntPoint.HasDataLabel = True
                End If
                strNumFormatData = pntPoint.DataLabel.NumberFormat
                pntPoint.HasDataLabel = blnHasLabel
                varArrYVals(2) = chtChart.SeriesCollection(1).Name
                varVal = chtChart.SeriesCollection(1).Values
                varArrOutput(2) = varVal
                On Error GoTo 0
            
            Case 87 'Bubble
                
                strListSep = Application.International(5)
                ReDim varArrOutput(1 To lngSrsCount, 1 To 4)
                
                strShtName = Replace(chtChart.Parent.Parent.Name, "'", "''")
                Application.Goto wbkActive.Worksheets(CStr(strShtName)).Range(CStr(strAcell))
                For lngLoopSrs = 1 To lngSrsCount
                    strFmla = chtChart.SeriesCollection(lngLoopSrs).Formula
                    strFmla = Mid$(strFmla, InStr(1, strFmla, "(") + 1)
                    strFmla = Replace(Replace(Replace(strFmla, strShtName, ""), "!", ""), ")", "")
                    varSpltFmla = Split(strFmla, strListSep)
                    strRange = vbNullString
                    For lngLoop = 0 To UBound(varSpltFmla)
                        If varSpltFmla(lngLoop) Like "$*$#*" Or varSpltFmla(lngLoop) Like "$*$#*:$*$#*" Then
                            strRange = strRange & strListSep & varSpltFmla(lngLoop)
                        ElseIf varSpltFmla(lngLoop) Like "{#*}" Then
                            varArrOutput(lngLoopSrs, 4) = CSng(Replace(Replace(varSpltFmla(lngLoop), "{", ""), "}", ""))
                            blnSizeStored = True
                        End If
                    Next
                    If Len(strRange) > Len(strListSep) Then
                        strRange = Mid$(strRange, Len(strListSep) + 1)
                        varSpltRange = Split(strRange, strListSep)
                        varArrOutput(lngLoopSrs, 1) = Evaluate("'" & strShtName & "'!" & varSpltRange(0))
                        varArrOutput(lngLoopSrs, 2) = Evaluate("'" & strShtName & "'!" & varSpltRange(1))
                        varArrOutput(lngLoopSrs, 3) = Evaluate("'" & strShtName & "'!" & varSpltRange(2))
                        If Not blnSizeStored Then
                            varArrOutput(lngLoopSrs, 4) = Evaluate("'" & strShtName & "'!" & varSpltRange(3))
                        End If
                    End If
                    blnSizeStored = False
                Next
                
                On Error Resume Next
                
                Set pntPoint = chtChart.SeriesCollection(1).Points(1)
                blnHasLabel = pntPoint.HasDataLabel
                
                varYVal = chtChart.Axes(1, 1).CategoryNames
                
                strNumFormatHeader = chtChart.Axes(1, xlPrimary).TickLabels.NumberFormat
                If strNumFormatHeader = vbNullString Then strNumFormatHeader = "@"
                
                If Not blnHasLabel Then
                    pntPoint.HasDataLabel = True
                End If
                
                strNumFormatData = pntPoint.DataLabel.NumberFormat
                pntPoint.HasDataLabel = blnHasLabel
                On Error GoTo 0
                
            Case Else
                GoTo Xit
        End Select
        
        Set wbkNew = Workbooks.Add(-4167)
        Set wksNew = wbkNew.Worksheets(1)
    
        If lngPlotBy = 1 Then
            
            For lngLoop = 1 To UBound(varArrOutput)
                wksNew.Cells(lngLoop, 1) = varArrYVals(lngLoop)
                wksNew.Cells(lngLoop, 2).Resize(, UBound(varArrOutput(lngLoop), 1)) = varArrOutput(lngLoop)
            Next
            wksNew.Cells(2, 2).Resize(UBound(varArrOutput), UBound(varArrOutput(1), 1)).NumberFormat = strNumFormatData
            On Error Resume Next
            wksNew.Cells(1, 2).Resize(, UBound(varYVal)).NumberFormat = "@"
            wksNew.Cells(1, 2).Resize(, UBound(varYVal)) = varYVal
            If Err.Number <> 0 Then
                wksNew.Cells(1, 2).Resize(, UBound(varArrOutput(1), 1)).NumberFormat = "@"
                wksNew.Cells(1, 2).Resize(, UBound(varArrOutput(1), 1)) = varYVal
                Err.Clear
            End If
            If Not blnFlag Then
                For lngLoop = 1 To lngSecSrsCnt
                    wksNew.Cells(1 + lngArrSecSrs(lngLoop), 2).Resize(, UBound(varArrOutput(lngLoop), 1)).NumberFormat = strNumFormatDataSec
                Next
            End If
            
        ElseIf lngPlotBy = 0 Then
            Select Case lngChartType
                Case 87
                    With wksNew.Range("a2")
                        .Resize(UBound(varArrOutput, 1), UBound(varArrOutput, 2)) = varArrOutput
                        .Offset(, 1).Resize(UBound(varArrOutput, 1), UBound(varArrOutput, 2) - 1).NumberFormat = strNumFormatData
                    End With
                Case Else
                    GoTo 2
            End Select
        ElseIf lngPlotBy = 2 Then
    2:
            On Error Resume Next
            For lngLoop = 1 To UBound(varArrOutput)
                wksNew.Cells(1, lngLoop) = varArrYVals(lngLoop)
                wksNew.Cells(2, lngLoop).Resize(UBound(varArrOutput(lngLoop), 1)) = Application.Transpose(varArrOutput(lngLoop))
            Next
            Err.Clear
            wksNew.Cells(2, 1).Resize(UBound(varYVal)).NumberFormat = "@"
            If Err.Number <> 0 Then
                wksNew.Cells(2, 1).Resize(UBound(varArrOutput(1), 1)).NumberFormat = "@"
                Err.Clear
            End If
            wksNew.Cells(2, 1).Resize(UBound(varYVal)) = Application.Transpose(varYVal)
            wksNew.Cells(2, 2).Resize(UBound(varArrOutput(1), 1), UBound(varArrOutput)).NumberFormat = strNumFormatData
            If Not blnFlag Then
                For lngLoop = 1 To lngSecSrsCnt
                    wksNew.Cells(2, 1 + lngArrSecSrs(lngLoop)).Resize(UBound(varArrOutput(1), 1), UBound(varArrOutput)).NumberFormat = strNumFormatDataSec
                Next
            End If
        End If
        wksNew.UsedRange.Columns.AutoFit
    Xit:
        If Err.Number <> 0 Then Err.Clear: On Error GoTo 0
        
        With Application
            .ScreenUpdating = lngSU
            .ScreenUpdating = True
        End With
    End Sub
    Insert another module and paste the following

    Code:
    Option Explicit
    
    Public Enum PasteFormat
        xl_Link = 0
        xl_HTML = 1
        xl_Bitmap = 2
        xl_Embed = 3
    End Enum
    
    Sub Copy_Paste_to_PowerPoint(ByRef ppApp As Object, ByRef ppSlide As Object, ByVal ObjectSheet As Worksheet, _
                                        ByRef PasteObject As Object, Optional ByVal Paste_Type As PasteFormat)
        
        '   Modified version of code originally posted here:
        '       http://www.vbaexpress.com/kb/getarticle.php?kb_id=370
        
        '   Modified by     : Admin @ ExcelFox.com
        '   Used Late binding so that no issues when users have multiple Excel version
        
        Dim PasteRange      As Boolean
        Dim objChart        As ChartObject
        Dim lngSU           As Long
        Dim strFName        As String
        
        Select Case TypeName(PasteObject)
            Case "Range"
                If Not TypeName(Selection) = "Range" Then Application.Goto PasteObject.Cells(1)
                PasteRange = True
            Case "Chart": Set objChart = PasteObject.Parent
            Case "ChartObject": Set objChart = PasteObject
            Case Else
                MsgBox PasteObject.Name & " is not a valid object to paste. Macro will exit", vbCritical
                Exit Sub
        End Select
        
        With Application
            lngSU = .ScreenUpdating
            .ScreenUpdating = 0
        End With
        
        ppApp.ActiveWindow.View.GotoSlide ppSlide.slidenumber
        
        On Error GoTo -1: On Error GoTo 0
        DoEvents
        
        If PasteRange Then
            If Paste_Type = xl_Bitmap Then
                '//Paste Range as Picture
                PasteObject.CopyPicture Appearance:=1, Format:=-4147
                ppSlide.Shapes.Paste.Select
            ElseIf Paste_Type = xl_HTML Then
                '//Paste Range as HTML
                PasteObject.Copy
                ppSlide.Shapes.PasteSpecial(8, link:=1).Select  'ppPasteHTML
            ElseIf Paste_Type = xl_Link Then
                '//Paste Range as Linked
                PasteObject.Copy
                ppSlide.Shapes.PasteSpecial(0, link:=1).Select   'ppPasteDefault
            End If
        Else
            If Paste_Type = xl_Link Then
                '//Copy & Paste Chart Linked
                objChart.Chart.ChartArea.Copy
                ppSlide.Shapes.PasteSpecial(link:=True).Select
            ElseIf Paste_Type = xl_Embed Then
                ppSlide.Shapes.AddOLEObject Left:=100, Top:=50, _
                        Width:=objChart.Width, Height:=objChart.Height, _
                        Filename:=WbkName
                ppSlide.Shapes(1).Select
                Kill WbkName
            ElseIf Paste_Type = xl_Link Then
                '//Copy & Paste Chart Not Linked
                objChart.Chart.CopyPicture Appearance:=1, Size:=1, Format:=2
                ppSlide.Shapes.Paste.Select
            End If
        End If
         
        '//Center pasted object in the slide
        ppApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
        ppApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True
    Xit:
        With Application
            .CutCopyMode = False
            .ScreenUpdating = lngSU
        End With
        
        AppActivate ("Microsoft Excel")
        
    End Sub
    and call the procedure like

    Code:
    Sub kTest()
        
        Dim ppApp       As Object
        Dim ppSlide     As Object
        Dim blnEmbed    As Boolean
        Dim objChart    As ChartObject
        
        blnEmbed = True
        
        On Error Resume Next
        Set ppApp = GetObject(, "Powerpoint.Application")
        On Error GoTo 0
        
        If ppApp Is Nothing Then
            Set ppApp = CreateObject("Powerpoint.Application")
            ppApp.Visible = True
            ppApp.presentations.Add
        End If
        
        
        If ppApp.ActivePresentation.Slides.Count = 0 Then
            Set ppSlide = ppApp.ActivePresentation.Slides.Add(1, 12) 'ppLayoutBlank
        Else
            ppApp.ActivePresentation.Slides.Add ppApp.ActivePresentation.Slides.Count + 1, 12
            Set ppSlide = ppApp.ActivePresentation.Slides(ppApp.ActivePresentation.Slides.Count)
        End If
        
        Set objChart = ThisWorkbook.Worksheets(1).ChartObjects(1)
        
        If blnEmbed Then
            Set wbkNew = Nothing
            WbkName = vbNullString
            GetChartData objChart
            If Not wbkNew Is Nothing Then
                wbkNew.Worksheets.Add wbkNew.Worksheets(1)
                objChart.Copy
                wbkNew.Worksheets(1).Paste
                wbkNew.Worksheets(1).ChartObjects(1).Chart.SetSourceData wbkNew.Worksheets(2).Range("a1").CurrentRegion
                wbkNew.SaveAs ThisWorkbook.Path & "\chart_temp.xlsx", 51
                WbkName = wbkNew.FullName
                wbkNew.Close
                Copy_Paste_to_PowerPoint ppApp, ppSlide, objChart.Parent, objChart.Chart, xl_Embed
            Else
                GoTo Xit
            End If
        Else
            Copy_Paste_to_PowerPoint ppApp, ppSlide, objChart.Parent, objChart.Chart, xl_Bitmap
        End If
        
    Xit:
    End Sub
    This will give you a start. Adjust the codes wherever necessary.
    Cheers !

    Excel Range to BBCode Table
    Use Social Networking Tools If You Like the Answers !

    Message to Cross Posters

    @ Home - Office 2010/2013/2016 on Win 10 (64 bit); @ Work - Office 2016 on Win 10 (64 bit)

  4. #4
    Junior Member
    Join Date
    May 2012
    Posts
    25
    Rep Power
    0
    Thanks Admin.
    I see you are creating a temp workbook to embed the chart. However, it does not give the same effect as PasteSpecial - "Use Destination Theme & Embed Workbook (H)". I am using Excel 2010.
    ,
    When i right-click the chartobject, i get 3 options:
    1] Open
    2] Edit
    3] Convert.

    But i do not get 'Edit Data' option, which i would normally get when i PasteSpecial into a new Presentation using option "Use Destination Theme & Embed Workbook (H)".

    When i select 'Edit' option, i get an embedded workbook in the chart itself and not as a standalone excel window.

    Can you try copying the chart and pasting it in a new powerpoint presentation and see the difference? See attached files for example.
    In ppt deck, slide 1 is from your code, slide 2 is manually pastespecial by me using option "Use Destination Theme & Embed Workbook (H)". You will notice the difference. When you right-click the 2nd slide chart, it opens a new workbook in a new window with title showing "Chart in Microsoft Excel". I am unable to replicate this option.

    Hope this is clear.
    Attached Files Attached Files

Similar Threads

  1. Copy/Paste Excel Range/Chart into Powerpoint VBA
    By Admin in forum Excel and VBA Tips and Tricks
    Replies: 1
    Last Post: 03-13-2014, 02:59 PM
  2. Add VBA Reference From Another Application Excel To PowerPoint
    By ds1001 in forum Rajan Verma's Corner
    Replies: 1
    Last Post: 06-02-2013, 02:43 PM
  3. Replies: 2
    Last Post: 04-14-2013, 08:23 PM
  4. Replies: 1
    Last Post: 05-20-2012, 12:23 PM
  5. Saving Embedded Picture From Excel Workbook Sheet To Folder Hard Drive
    By littleiitin in forum Excel and VBA Tips and Tricks
    Replies: 0
    Last Post: 10-31-2011, 02:31 PM

Tags for this Thread

Posting Permissions

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