Excel VBA 到 PPT 不能在办公室工作 365 64 位

Question

我在 excel 的所有版本上都使用了以下代码 - 基本上我创建了一个具有 ppt 外观的 excel 工作表并将工作表范围导出到 PPT。

Excel VBA 导出到 PPT 在 Office 365 32 位之前的所有版本中都可以正常工作

• 它不适用于 365 64 位，Windows 10 操作系统

尝试了以下检查参考 - 使用 14,15,16 object 库 - 工作正常..

不适用于 64 位 - Excel 365 给出错误 - “找不到 PowerPoint”

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

我对 Excel 和 On Error Resume Next 代码有类似的问题。 尽管我很少使用它（我更喜欢体验所有错误并适当地处理它们），但它在某些有限的情况下可能很有用。 我找到了重新思考一些代码的方法，例如，在你的例子中你展示了这个：

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

我将把这段代码重新编码如下：

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

使用此技术，您无需尝试设置 object，除非您知道它可用。 此外，由于您没有使用引发的错误，因此您不必处理一些错误“清理”。