请修改PPT宏

Question

我有下面的宏。

请你修改它，以便在顶部显示幻灯片编号，并提取笔记页面。

我尝试了所有方法，但无法得到答案 - ：

Sub WriteToWord()
    Dim aSlide As Slide, MyDoc As New Word.Document, MyRange As Word.Range
    Dim aTable As Table, aShape As Shape, TablesCount As Integer, ShapesCount As Integer
    Dim i As Word.Paragraph
    On Error Resume Next
    With MyDoc
        .Application.Visible = False
        .Application.ScreenUpdating = False
        For Each aSlide In ActivePresentation.Slides
            For Each aShape In aSlide.Shapes
                Set MyRange = .Range(.Content.End - 1, .Content.End - 1)
                Select Case aShape.Type
                Case msoAutoShape, msoPlaceholder, msoTextBox
                    If aShape.TextFrame.HasText Then
                        aShape.TextFrame.TextRange.Copy
                        MyRange.Paste
                        With MyRange
                            .ParagraphFormat.Alignment = wdAlignParagraphLeft
                            For Each i In MyRange.Paragraphs
                                If i.Range.Font.Size >= 16 Then
                                    i.Range.Font.Size = 14
                                Else
                                    i.Range.Font.Size = 12
                                End If
                            Next
                        End With
                    End If
                Case msoPicture
                    aShape.Copy
                    MyRange.PasteSpecial DataType:=wdPasteMetafilePicture
                    ShapesCount = .Shapes.Count
                    With .Shapes(ShapesCount)
                        .LockAspectRatio = msoFalse
                        .Width = Word.CentimetersToPoints(14)
                        .Height = Word.CentimetersToPoints(6)
                        .Left = wdShapeCenter
                        .ConvertToInlineShape
                    End With
                    .Content.InsertAfter Chr(13)
                Case msoEmbeddedOLEObject, msoLinkedOLEObject, msoLinkedPicture, msoOLEControlObject
                    aShape.Copy
                    MyRange.PasteSpecial DataType:=wdPasteOLEObject
                    ShapesCount = .Shapes.Count
                    With .Shapes(ShapesCount)
                        .LockAspectRatio = msoFalse
                        .Width = Word.CentimetersToPoints(14)
                        .Height = Word.CentimetersToPoints(6)
                        .Left = wdShapeCenter
                        .ConvertToInlineShape
                    End With
                    .Content.InsertAfter Chr(13)
                Case msoTable
                    aShape.Copy
                    MyRange.Paste
                    TablesCount = .Tables.Count
                    With .Tables(TablesCount)
                        .PreferredWidthType = wdPreferredWidthPercent
                        .PreferredWidth = 100
                        .Range.Font.Size = 11
                    End With
                    .Content.InsertAfter Chr(13)
                End Select
            Next
            If aSlide.SlideIndex < ActivePresentation.Slides.Count Then .Content.InsertAfter Chr(12)
            .UndoClear ' Clear used memory
        Next
         ' Change white font to black color
        With .Content.Find
            .ClearFormatting
            .Format = True
            .Font.Color = wdColorWhite
            .Replacement.Font.Color = wdColorAutomatic
            .Execute Replace:=wdReplaceAll
        End With
        MsgBox "PPT Converted to WORD completed, Please check and save document", vbInformation + vbOKOnly, "ExcelHome/ShouRou"
        .Application.Visible = True
        .Application.ScreenUpdating = True
    End With
End Sub

Sub Auto_Open() ' Add PPTtoWord to Tool Bar when Powerpoint start
    Dim MyControl As CommandBarControl
    On Error Resume Next
    Application.CommandBars("Standard").Controls("PPTtoWord").Delete
    Set MyControl = Application.CommandBars("Standard").Controls.Add(Before:=1)
    With MyControl
        .Caption = "PPTtoWord"
        .FaceId = 567 ' Word Icon
        .Enabled = True
        .Visible = True
        .Width = 100
        .OnAction = "WriteToWord"
        .Style = msoButtonIconAndCaption
    End With
End Sub

Sub Auto_Close() ' Delete PPTtoWord from Tool Bar when Powerpoint close
    On Error Resume Next
    Application.CommandBars("Standard").Controls("PPTtoWord").Delete
End Sub

Answer 1

您正在使用Word运行此功能并使用早期绑定自动化PowerPoint，您需要完全限定任何PowerPoint参考。

• 您是否添加了对PowerPoint库的引用。
• 更改为aShape As PowerPoint.Shape

• 抓取对PowerPoint正在运行的实例的引用。 PowerPoint是单实例多用途，因此您可以使用它。

  Dim PPT as PowerPoint.Application Set PPT = CreateObject("PowerPoint.Application")

• 使用ActivePresentation
完全限定对PPT.ActivePresentation的所有引用

您的宏应该运行并生成一些内容，以便您可以继续调试。