Excel VBA to PPT not working in office 365 64 bit

Question

I was using the below code just fine on all the version of excel - Basically I created a excel sheet with ppt look and export the sheet range to PPT.

Excel VBA to Export to PPT works fine in all versions till office 365 32bit

• Its not working in 365 64 bit, Windows 10 OS

Tried the following Checked reference - with 14,15,16 object library - works fine..

Not working on 64bit - Excel 365 Error given - "PowerPoint Not found"

Sub ExcelRangeToPPT_new_now()

    'prepareppt

    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    Application.IgnoreRemoteRequests = True

    Dim rng As Range
    Dim PowerPointApp As Object
    Dim myPresentation As Object
    Dim mySlide As Object
    Dim myShape As Object

    'Sheets("S19").Select

    'Copy Range from Excel
    Set rng = ThisWorkbook.ActiveSheet.Range("A1:q36")

    On Error Resume Next
    'Is PowerPoint already opened?
    Set PowerPointApp = GetObject(class:="PowerPoint.Application")
    'Clear the error between errors
    err.Clear
    'If PowerPoint is not already open then open PowerPoint
    If PowerPointApp Is Nothing Then Set PowerPointApp = CreateObject(class:="PowerPoint.Application")
    'Handle if the PowerPoint Application is not found
    If err.Number = 429 Then
        MsgBox "PowerPoint could not be found, aborting."
        Exit Sub
    End If

    Sheets("template").Select

    Set rng = ThisWorkbook.ActiveSheet.Range("A1:q36")
    instfile = "Noattach"
    If ActFileName = False Then
        'PowerPointApp.Activate
        'PowerPointApp.Presentations.Add
        'Set PP_File = PowerPointApp.ActivePresentation
    Else
        PowerPointApp.Activate
        Set myPresentation = PowerPointApp.Presentations.Open(ActFileName)

    End If


    Set myPresentation = PowerPointApp.Presentations.Add
    Set PP_File = PowerPointApp.ActivePresentation


adddd:
    DoEvents
    Set rng = ThisWorkbook.ActiveSheet.Range("A1:q36")
    PowerPointApp.Visible = True
    'Create a New Presentation


rrr:
    err.Clear
    Set mySlide = PP_File.Slides.Add(1, 12)      '11 = ppLayoutTitleOnly
    PP_File.Slides (PPApp.ActiveWindow.Selection.SlideRange.SlideIndex)
    With PP_File.PageSetup
        .SlideSize = ppSlideSizeCustom
        .SlideWidth = 720
        .SlideHeight = 528
        .FirstSlideNumber = 1
        .SlideOrientation = msoOrientationHorizontal
        .NotesOrientation = msoOrientationVertical
    End With

    rng.Copy
    mySlide.Shapes.PasteSpecial DataType:=2      '2 = ppPasteEnhancedMetafile
    Set myShape = mySlide.Shapes(mySlide.Shapes.Count)
    'Set position:
    myShape.Left = 0
    myShape.Top = 0
    myShape.LockAspectRatio = msoFalse
    myShape.HEIGHT = 528
    myShape.WIDTH = 718

    If instfile <> "Noattach" Then
        Dim objPPTShape As Object
        Set objPPTShape = PP_File.Slides(1).Shapes.AddOLEObject(Left:=100, Top:=100, WIDTH:=700, HEIGHT:=300, _
                                                                filename:=instfile, DisplayAsIcon:=True) 'OR Use , Filename:="E:\Documents and Settings\User\My Documents\abc.xlsm" instead of ClassName but not both
        With objPPTShape
            .Left = 475
            .Top = 350
        End With
        Set objPPTShape = Nothing
    End If

    PowerPointApp.Visible = True
    PowerPointApp.Activate
    Application.CutCopyMode = False
    PowerPointApp.PageSetup.SlideOrientation = msoOrientationHorizontal

    sht = sht - 1

    If sht = 1 Then Sheets("template").Select: GoTo ttre
    instfile = "Noattach"
    If sht = 2 Then Sheets("S2").Select: GoTo adddd


ttre:
    Sheets("main").Select
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    Application.IgnoreRemoteRequests = False

    MsgBox "PPT Created Sucessfully.. Kindly review it before saving it.. "
    Exit Sub


err:
    Debug.Print "Error No.: " & err.Number & vbNewLine & vbNewLine & "Description: " & err.Description, vbCritical, "Error"

    If err.Number = -2147467259 Then
        MsgBox "Error Occured - Check if the Files to be embedded  or the destination PPT is in the same folder as that of the Excel file..."
    End If
    If err.Number = 462 Then
        Set PP_File = PowerPointApp.Presentations.Add
        GoTo rrr
    End If
    If err.Number = 16 Then
        MsgBox "Check if the Excel Files to be embedded is in the same folder.."
        End
    End If

End Sub

Answer 1

I have a similar issue with Excel and the On Error Resume Next code. Although I use it sparingly (I prefer to experience all the errors and handle them appropriately) it can be useful in some limited situations. I have found ways to rethink some code, in your for example you show this:

On Error Resume Next
'Is PowerPoint already opened?
Set PowerPointApp = GetObject(class:="PowerPoint.Application")
'Clear the error between errors
err.Clear
'If PowerPoint is not already open then open PowerPoint
If PowerPointApp Is Nothing Then Set PowerPointApp = CreateObject(class:="PowerPoint.Application")

I would recode this piece as follows:

bPPOpen = GetObject(class:="PowerPoint.Application")
If bPPOpen Then 
   Set PowerPointApp = GetObject(class:="PowerPoint.Application")
Else bPPOpen = False Then
   Set PowerPointApp = CreateObject(class:="PowerPoint.Application")
Endif

Using this technique you never have to attempt to SET the object unless you know it's available. Further, since you are not using a raised error you don't have to deal with some of the error 'clean up'.