Link to home
Start Free TrialLog in
Avatar of montrof
montrofFlag for United States of America

asked on

VBA Works in Excel 2007 Not in 2013 Copy to PPT

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
Avatar of Rgonzo1971
Rgonzo1971

Hi,

in XL you have to define all your PPT values

like

Const ppPasteEnhancedMetafile = 2
Const ppViewNormal = 9


Regards
ASKER CERTIFIED SOLUTION
Avatar of John Wilson
John Wilson
Flag of United Kingdom of Great Britain and Northern Ireland image

Link to home
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
Start Free Trial
Avatar of montrof

ASKER

@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
So did you read my comment about Shaperanges??
Avatar of montrof

ASKER

Thanks for the help