Solved

VBA Works in Excel 2007 Not in 2013 Copy to PPT

Posted on 2013-12-04
5
1,790 Views
Last Modified: 2013-12-05
Hi,

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
            delPPTShapesActiveSlide
        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)

endLoop1:
        Next

        oPPTApp.Activate

        Set oPPTApp = Nothing

    Else
        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
    Err.Clear
    ' Select the range then copy it.

    On Error GoTo 0
    Range(ExcelSlide).Worksheet.Activate
    ActiveSheet.ChartObjects(strRange).Activate
    ActiveChart.ChartArea.Copy
    Range("A1").Select

    ' 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




Thanks,
Montrof
0
Comment
Question by:montrof
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
  • 2
  • 2
5 Comments
 
LVL 51

Expert Comment

by:Rgonzo1971
ID: 39697661
Hi,

in XL you have to define all your PPT values

like

Const ppPasteEnhancedMetafile = 2
Const ppViewNormal = 9


Regards
0
 
LVL 23

Accepted Solution

by:
JSRWilson earned 500 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.

@montrof

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
0
 
LVL 1

Author Comment

by:montrof
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.  

Thanks,
Montrof
0
 
LVL 23

Expert Comment

by:JSRWilson
ID: 39698134
So did you read my comment about Shaperanges??
0
 
LVL 1

Author Closing Comment

by:montrof
ID: 39698344
Thanks for the help
0

Featured Post

Increase your protection from Zero Day threats!

Running two Antivirus' is never a good idea.
Taking advantage of Multiple Security layers on the other hand can often save your hide.
See which top notch security software brands have been proven to happily coexist together.
Reduce your chances of becoming a statistic.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

How to get Spreadsheet Compare 2016 working with the 64 bit version of Office 2016
I was prompted to write this article after the recent World-Wide Ransomware outbreak. For years now, System Administrators around the world have used the excuse of "Waiting a Bit" before applying Security Patch Updates. This type of reasoning to me …
Excel styles will make formatting consistent and let you apply and change formatting faster. In this tutorial, you'll learn how to use Excel's built-in styles, how to modify styles, and how to create your own. You'll also learn how to use your custo…
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…

734 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