试图将幻灯片标题从 PowerPoint 复制到 excel

Question

我对 excel VBA 还是很陌生，我想将幻灯片标题从 PPT 中的所有幻灯片复制到 Excel（粘贴，然后转到下一行并粘贴）

但目前，我只能得出以下看起来非常愚蠢的代码。 如果有人能简化我的代码，我将不胜感激，这样当有 100 多张幻灯片时，我就不必重复这么多行代码

Sub CopySlideTitle()
'Stupid way of doing things
Dim ppt As PowerPoint.Application
Set ppt = New PowerPoint.Application
ppt.Visible = msoTrue
ppt.Presentations.Open ("C:\Users\geral\Desktop\Test.pptm")
Dim ppPres As PowerPoint.Presentation
Set ppPres = ppt.ActivePresentation

Dim ppSlide As Slide


Dim SlideText01 As String, SlideText02 As String, SlideText03 As String, _
SlideText04 As String, SlideText05 As String, SlideText06 As String, _
SlideText07 As String, SlideText08 As String, SlideText09 As String, _
SlideText10 As String

SlideText01 = ppPres.Slides(1).Shapes("SlideTitle").TextFrame.TextRange.Text
SlideText02 = ppPres.Slides(2).Shapes("SlideTitle").TextFrame.TextRange.Text
SlideText03 = ppPres.Slides(3).Shapes("SlideTitle").TextFrame.TextRange.Text
SlideText04 = ppPres.Slides(4).Shapes("SlideTitle").TextFrame.TextRange.Text
SlideText05 = ppPres.Slides(5).Shapes("SlideTitle").TextFrame.TextRange.Text
SlideText06 = ppPres.Slides(6).Shapes("SlideTitle").TextFrame.TextRange.Text
SlideText07 = ppPres.Slides(7).Shapes("SlideTitle").TextFrame.TextRange.Text
SlideText08 = ppPres.Slides(8).Shapes("SlideTitle").TextFrame.TextRange.Text
SlideText09 = ppPres.Slides(9).Shapes("SlideTitle").TextFrame.TextRange.Text
SlideText10 = ppPres.Slides(10).Shapes("SlideTitle").TextFrame.TextRange.Text

Range("A1").Value = SlideText01
Range("A2").Value = SlideText02
Range("A3").Value = SlideText03
Range("A4").Value = SlideText04
Range("A5").Value = SlideText05
Range("A6").Value = SlideText06
Range("A7").Value = SlideText07
Range("A8").Value = SlideText08
Range("A9").Value = SlideText09
Range("A10").Value = SlideText10

End Sub

在此先感谢几百万

Answer 1

您可以按如下方式循环播放每张幻灯片...

Sub CopySlideTitle()

    Dim ppApp As PowerPoint.Application
    Dim ppPres As PowerPoint.Presentation
    Dim ppSlide As PowerPoint.Slide
    Dim oRow As Long

    Set ppApp = New PowerPoint.Application
    ppApp.Visible = msoTrue

    Set ppPres = ppApp.Presentations.Open("C:\Users\geral\Desktop\Test.pptm")

    oRow = 1
    For Each ppSlide In ppPres.Slides
        Cells(oRow, "A").Value = ppSlide.Shapes("SlideTitle").TextFrame.TextRange.Text
        oRow = oRow + 1
    Next ppSlide

End Sub

但是，这是另一种方式。这种方法循环遍历每张幻灯片，然后循环遍历幻灯片中的每个占位符，然后检查占位符是否为标题，然后检索其文本。

Sub CopySlideTitle()

    Dim ppApp As PowerPoint.Application
    Dim ppPres As PowerPoint.Presentation
    Dim ppSlide As PowerPoint.Slide
    Dim ppPlaceHolder As PowerPoint.Shape
    Dim oRow As Long

    Set ppApp = New PowerPoint.Application
    ppApp.Visible = msoTrue

    Set ppPres = ppApp.Presentations.Open("C:\Users\geral\Desktop\Test.pptm")

    oRow = 1
    For Each ppSlide In ppPres.Slides
        For Each ppPlaceHolder In ppSlide.Shapes.Placeholders
            If ppPlaceHolder.PlaceholderFormat.Type = ppPlaceholderTitle Then
                Cells(oRow, "A").Value = ppPlaceHolder.TextFrame.TextRange.Text
                oRow = oRow + 1
                Exit For
            End If
        Next ppPlaceHolder
    Next ppSlide

End Sub

另外，如果您想在“标题”页面中包含标题，则需要替换...

If ppPlaceHolder.PlaceholderFormat.Type = ppPlaceholderTitle Then

与

If ppPlaceHolder.PlaceholderFormat.Type = ppPlaceholderCenterTitle Or _
                ppPlaceHolder.PlaceholderFormat.Type = ppPlaceholderTitle Then

希望这会有所帮助！