Excel VBA для PPT не работает в офисе 365 64 бит

Question

Я использовал приведенный ниже код очень хорошо на всех версиях Excel - в основном я создал лист Excel с внешним видом ppt и экспортировал диапазон листов в PPT.

Excel VBA для экспорта в PPT отлично работает во всех версиях до Office 365 32-битный

• Не работает в 365 64-битных, ОС Windows 10

Пробовал следующую Проверенную ссылку - с 14,15,16 объектной библиотекой - работает нормально ..

Не работает на 64-битной версии - Ошибка Excel 365 - "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