Excel VBA 到 PPT 在 Office 365 64 位中不起作用

Posted 2023-03-29

【中文标题】Excel VBA 到 PPT 在 Office 365 64 位中不起作用

【英文标题】：Excel VBA to PPT not working in office 365 64 bit

【发布时间】：2020-01-21 18:44:45

【问题描述】：

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

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

它不能在 365 64 位、Windows 10 操作系统中运行

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

不适用于 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

【问题讨论】：

我在 Windows 10 下的 64 位 Office 2019 下没有看到任何错误。可能您在一台机器上遇到了配置问题。

Yaaa 多台 PC，这就是原因

请注意，就像您使用 On Error Resume Next 一样，它会隐藏 所有 错误消息，直到 End Sub 这是一个非常糟糕的做法。在错误检查err.Number = 429 的End If 之后，切勿在没有On Error Goto 0 的情况下使用它（重新激活错误报告）。见Excel Easy - Debugging。如果删除On Error Resume Next，会在哪一行出现错误？

同时使用.Select 是一个非常糟糕的做法，您应该修复：How to avoid using Select in Excel VBA。 • 您还使用了很多GoTo，应该不惜一切代价避免它，因为它会严重地弄乱您的代码。 GoTo 只能与On Error … 结合使用。

我确实检查了.. 它确实触发了 - err.Number = 429.. 即使你安装或打开了 powerpoint.. - 没关系..

【参考方案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

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