试图将幻灯片标题从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

希望这可以帮助！