VBA Works in Excel 2007 Not in 2013 Copy to PPT

Posted on 2013-12-04
Medium Priority
Last Modified: 2013-12-05

I have been using the below code for a long time in Excel 2007 and PPT 2007. I am now using Excel 2013 and PPT 2013 and the code is erroring out at

For lngRow = Range("FirstRange").Row To Cells(Rows.Count, Range("FirstRange").Column).End(xlUp).Row

Saying  Run time error '1004': Method 'Range' of object'_Globail' failed

I also get an error saying object not defined at

With shShape
        .LockAspectRatio = 0

Not sure what the issue is

Sub UpdatePPT()

    Dim oPPTApp As PowerPoint.Application
    Dim oPPTShape As PowerPoint.Shape
    Dim shtControl As Worksheet
    Dim rngNewRange As Excel.Range, strSlideNum As String
    Dim oSheet As Object, shShape As Object, nmName As Name
    Dim lngRow As Long, strLeaveOpen As String, strPrevWbk As String, _
        blPrevWbkXist As Boolean
    Dim strWbk As String, strRange As String, intSlideNum As Integer, _
        intWidth As Integer, intTop As Integer, intLeft As Integer, _
        intHeight As Integer, strWbkName As String, strError As String, ExcelSlide As String
    Dim Answer As String
    Dim MyMessage As String
    Dim DrugSelected As String
    Dim Parameter As String

    Application.ScreenUpdating = False

    ' Set oPPTApp to PowerPoint by creating a new instance of PowerPoint.
    ' If PowerPoint is already open, you would instead use the GetObject
    ' method instead.

    DrugSelected = Worksheets("Parameters").Range("J150").Value
    Parameter = Worksheets("Parameters").Range("J151").Value
    MyMessage = ("You are about to copy drug information for " & DrugSelected & " with Parameter " & Parameter & " information to PowerPoint, please click Yes to proceed or No to end process")
    Answer = MsgBox(MyMessage, vbQuestion + vbYesNo)

    Call wsProtection
    If Answer = vbYes Then

        Set shtControl = Worksheets("Copy to PPT")
        Set oPPTApp = CreateObject("PowerPoint.Application")

        ' Set PowerPoint to be Visible.
        oPPTApp.Visible = msoTrue
        ' Open Presentation
        oPPTApp.Presentations.Open Worksheets("Copy to PPT").Range("PPT_Path").Value
        ' Delete existing shapes
        If Worksheets("Copy to PPT").Range("I1").Value = "YES" Then
        ElseIf Worksheets("Copy to PPT").Range("I1").Value = "NO" Then
            Worksheets("Copy to PPT").Range("I1").Value = "YES"
        End If
        'Loop through all Range lines
        For lngRow = Range("FirstRange").Row To Cells(Rows.Count, Range("FirstRange").Column).End(xlUp).Row
            If UCase(shtControl.Cells(lngRow, 9).Value) = "NO" Then GoTo endLoop1

            With shtControl
                strRange = .Cells(lngRow, 3).Value
                intTop = .Cells(lngRow, 4).Value
                intLeft = .Cells(lngRow, 5).Value
                intWidth = .Cells(lngRow, 6).Value
                intHeight = .Cells(lngRow, 7).Value
                intSlideNum = .Cells(lngRow, 8).Value
                ExcelSlide = .Cells(lngRow, 3).Value
            End With

            'transfer to Powerpoint
            strError = strError & CopyRangeToPPT(oPPTApp, intSlideNum, intLeft, intWidth, intHeight, intTop, strRange, ExcelSlide)



        Set oPPTApp = Nothing

        Exit Sub

    End If

    Worksheets("Copy to PPT").Select

    Call wsProtection

    Application.ScreenUpdating = True

    MsgBox "Power Point Update Complete"

End Sub
Sub GetPPTPath()
    Range("PPT_Path").Value = Application.GetOpenFilename
End Sub
Sub GetXLPath()
    Range("XL_Path").Value = Application.GetOpenFilename
End Sub
Function CopyRangeToPPT(oPPTApp As PowerPoint.Application, intSlideNum As Integer, intLeft As Integer, intWidth As Integer, intHeight As Integer, intTop As Integer, strRange As String, ExcelSlide As String) As String
    Dim shShape As Object, strError As String

    'delete shape if it exists on slide
    On Error Resume Next
    oPPTApp.ActivePresentation.Slides("Slide_" & strRange).Shapes("ExcelSlide_" & strRange).Delete
    If Err.Number <> 0 Then CopyRangeToPPT = Err.Number & " " & Err.Description & ": " & strRange & vbCrLf
    ' Select the range then copy it.

    On Error GoTo 0

    ' Paste the range

    Set shShape = oPPTApp.ActivePresentation.Slides(intSlideNum).Shapes.PasteSpecial(ppPasteEnhancedMetafile)

    ''    oPPTApp.Run ("ResizeShapeSize")

    ' Align the pasted range

    With shShape
        .LockAspectRatio = 0
        .Left = intLeft
        .Top = intTop
        .Width = intWidth
        .Height = intHeight
        .Name = "ExcelSlide_" & strRange
    End With

End Function
Sub delPPTShapesActiveSlide()    'deletes inserted objects that where inserted previously by macro
    Dim oPPTApp As Object
    Dim oPPTFile As Object
    Dim oPPTSlide As Object
    Dim i As Long
    Set oPPTApp = GetObject(, "Powerpoint.Application")
    Set oPPTFile = oPPTApp.ActivePresentation
    oPPTApp.ActiveWindow.ViewType = 1
    For Each oPPTSlide In oPPTFile.Slides
        If oPPTSlide.SlideIndex > 3 Then
            For i = oPPTSlide.Shapes.Count To 1 Step -1
                If oPPTSlide.Shapes(i).Name Like "ExcelSlide_*" Then oPPTSlide.Shapes(i).Delete
            Next i
        End If
    Next oPPTSlide

    oPPTApp.ActiveWindow.ViewType = ppViewNormal
    Set oPPTApp = Nothing
    Set oPPTFile = Nothing
    Set oPPTSlide = Nothing
End Sub

Open in new window

Question by:montrof
  • 2
  • 2
LVL 54

Expert Comment

ID: 39697661

in XL you have to define all your PPT values


Const ppPasteEnhancedMetafile = 2
Const ppViewNormal = 9

LVL 23

Accepted Solution

JSRWilson earned 2000 total points
ID: 39697690
@ Rgonzo

The poster clearly has created a reference to PPT code with early binding so the PPT values would work fine.


Without seeing the Excel file it is very difficult to unravel your code. Are you sure whatever you copies can be pasted as an EMF?? If you paste special each of the items manually is EMF one of the options.

There are also errors in your code:

There'a a rogue period and no wsProtection sub routine. I guess these are typos.

More important :

PasteSpecial always returns a ShapeRange NOT a Shape. You have declared  shShape as an object which works but treated it as a shape. 2010 will tolerate this even though it is incorrect. I think 2013 will require you to use it correctly, ie Shapes(1) in the Range

    With shShape(1)
        .LockAspectRatio = 0
        .Left = intLeft
        .Top = intTop
        .Width = intWidth
        .Height = intHeight
        .Name = "ExcelSlide_" & strRange
    End With

Author Comment

ID: 39698048
@JSRWilson Thank you for the response, I am able to paste with EMF option manually also the code runs without a problem in 2007.  

LVL 23

Expert Comment

ID: 39698134
So did you read my comment about Shaperanges??

Author Closing Comment

ID: 39698344
Thanks for the help

Featured Post

Never miss a deadline with monday.com

The revolutionary project management tool is here!   Plan visually with a single glance and make sure your projects get done.

Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

Join & Write a Comment

In this post, we will learn to set up the Group Naming policy and will see how it is going to impact the Display Name and the Email addresses of the Group.
This tutorial summarizes the causes behind"an unknown error prevented access to the PST File”.  It also suggests the various solutions to fix the problem.
This Micro Tutorial demonstrates in Microsoft Excel how to consolidate your marketing data by creating an interactive charts using form controls. This creates cool drop-downs for viewers of your chart to choose from.
Finds all prime numbers in a range requested and places them in a public primes() array. I've demostrated a template size of 30 (2 * 3 * 5) but larger templates can be built such 210  (2 * 3 * 5 * 7) or 2310  (2 * 3 * 5 * 7 * 11). The larger templa…

600 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question