Excel VBA to PPT not working in office 365 64 bit - excel

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'.