2

我正在尝试将多个 PowerPoint 文件中的文本提取到 txt 文件或 excel 文件中。

问题是，我试图只提取具有特定文本标题的幻灯片。由于我有几个 PowerPoint 文件，我希望我的导出文件也可以创建为几个单独的文件。

我相信可以运行一个可以做到这一点的宏，但我不完全确定。这实际上是否可能，如果可以，最好的编码方式是什么？

理论上，这应该是一个简单的“IF”语句，但我对 VBA 不是很好，也不熟悉。

我一直在使用以下代码：（第二组代码） http://www.pptfaq.com/FAQ00274_Export_Text_to_a_text_file-_extract_text_from_PowerPoint_-Mac_or_PC-.htm

以及此链接：（也是第二组代码） 从 VBA 中的 powerpoint 文件中提取所有文本

第一个链接将文本提取到 txt 文件中，但不允许我提取具有特定标题幻灯片的文本。它似乎还有一行代码可以识别标题幻灯片，这似乎会有所帮助。第二个链接可以导出多个 txt 文件，但我的输出 txt 文件是空白的，也就是我无法让它工作。

我敢肯定，对于任何试图在多个 PowerPoint 中对大量数据进行排序的人来说，这样的东西都会很有用。

如果有人有任何想法，那就太好了！

跟进

根据我们在下面评论中的讨论，我添加了 LIKE 和通配符 ("*") 函数，以便代码返回幻灯片标题为“Walkthrough:”+（单词 walkthrough 之后的任何内容）的所有文本。当我尝试添加 like 函数时，它会导致 .txt 文件仅显示第一行文本。

至于超链接。它们仍然显示为显示文本。

Siddharth Rout，感谢您迄今为止对我的所有帮助和耐心。

跟进(2) 

'~~> Change Slide Title here
Const ppSTitle As String = "Walkthrough"
'~~> Change PPT Source Directory Here
Const sDir As String = "C:\Documents and Settings\r126162\Desktop\test\"

Sub Sample()
    Dim ppPrsn As Presentation
    Dim ppSlide As Slide
    Dim filesize As Integer
    Dim shp As Shape
    Dim vFile
    Dim No As Long

    vFile = Dir(sDir & "*.ppt*")

    No = 1

    Do While vFile <> ""
        Set ppPrsn = Presentations.Open(FileName:=sDir & vFile)

        For Each ppSlide In ppPrsn.Slides
            If InStr(1, ppSlide.Shapes.Title.TextFrame.TextRange.Text, ppSTitle, vbTextCompare) Then
                '~~> Get a free file handle
                filesize = FreeFile()

                '~~> Open your file
                Open vFile & ".txt" For Output As #filesize

                For Each shp In ppSlide.Shapes
                    If shp.HasTextFrame Then
                        If shp.TextFrame.HasText Then
                            '~~> Export Text
                            Print #filesize, shp.TextFrame.TextRange.Text & " " & shp.TextFrame.TextRange.Characters.ActionSettings(ppMouseClick).Hyperlink.Address
                        End If
                    End If
                Next

                Close #filesize

                No = No + 1
                Exit For
            End If
        Next

        ppPrsn.Close
        vFile = Dir
    Loop
    Set ppPrsn = Nothing
End Sub
4

2 回答 2

1

如果定义的字符串可用，此代码会查看每个形状。
如果可用，它将使用文件系统对象将形状包含的文本写入文本文件。
要使用它，您需要参考 MS Scripting Runtime 库。
此外，我还提供了一种遍历指定文件夹并检索可用 PowerPoint 演示文稿的方法。

Option Explicit

Sub Get_PPT()

Dim oApp                As PowerPoint.Application
Dim oPres               As PowerPoint.Presentation
Dim oSlides             As PowerPoint.Slides
Dim oSlide              As PowerPoint.Slide
Dim oShapes             As PowerPoint.Shapes
Dim oShape              As PowerPoint.Shape
Dim sFolder             As String
Dim sFile               As String
Dim sPath               As String
Dim sSearch             As String
Dim sTitle              As String
Dim iCnt                As Integer

Dim FSO_Ext             As FileSystemObject
Dim FSO                 As FileSystemObject
Dim FSOFile             As TextStream
Dim sFilePath           As String
Dim iNoOfLoop           As Integer
Dim sExtension          As String


Set oApp = CreateObject("Powerpoint.Application")

sFolder = "U:"
If sFolder <> "" Then
    If Right(sFolder, 1) <> "\" Then
        sFolder = sFolder & "\"
    End If
    sFile = Dir(sFolder, vbNormal)
    Do While sFile <> ""
        sPath = sFolder & sFile
        Set FSO_Ext = New FileSystemObject
        sExtension = FSO_Ext.GetExtensionName(sPath)
        If sExtension = "ppt" Or sExtension = "pptx" Then
            Set oPres = oApp.Presentations.Open(sPath)
            sSearch = "partner"
            For Each oSlide In oPres.Slides
                Set oShapes = oSlide.Shapes
                For Each oShape In oShapes
                    If oShape.HasTextFrame Then
                        Debug.Print sTitle
                        sTitle = oShape.TextFrame.TextRange.Text

                        If InStr(UCase(Trim(sTitle)), UCase(Trim(sSearch))) <> 0 Then
                            iCnt = iCnt + 1
                            sFilePath = sPath & iCnt & ".txt"
                            Set FSO = New FileSystemObject
                            Set FSOFile = FSO.OpenTextFile(sFilePath, 2, True)
                            FSOFile.writeline (sTitle)
                            FSOFile.Close
                        End If
                    End If
                Next oShape
            Next oSlide
            Set oSlides = Nothing
            Set oShapes = Nothing
            oPres.Close
        End If
        Set FSO_Ext = Nothing
    sFile = Dir
    Loop
End If

oApp.Quit

End Sub

请注意，没有什么可以阻止您自定义此代码。
例如，假设您想在文本文件中添加更多行（由同一张幻灯片中的其他形状包含），您可以通过将“Writeline”放在一个循环中来使用 FSO 编写多行： 

For iCnt = 1 To 5 
    FSOFile.WriteLine ("Text at line" & iCnt) 
Next iCnt
于 2012-07-25T09:51:53.320 回答
1

第一个链接将文本提取到 txt 文件中，但不允许我提取具有特定标题幻灯片的文本。

这对我有用

'~~> Change Title here
Const ppSTitle As String = "Title1"
'~~> Change File Name here
Const FlName = "C:\Sample.Txt"

Sub Sample()
    Dim ppPrsn As Presentation
    Dim ppSlide As Slide
    Dim filesize As Integer
    Dim shp As Shape

    Set ppPrsn = ActivePresentation

    For Each ppSlide In ppPrsn.Slides
        If ppSlide.Shapes.Title.TextFrame.TextRange.Text = ppSTitle Then

            '~~> Get a free file handle
            filesize = FreeFile()

            '~~> Open your file
            Open FlName For Output As #filesize

            For Each shp In ppSlide.Shapes
                If shp.HasTextFrame Then
                    If shp.TextFrame.HasText Then
                        '~~> Export Text
                        Print #filesize, shp.TextFrame.TextRange.Text
                        Debug.Print
                    End If
                End If
            Next

            Close #filesize

            Exit For
        End If
    Next
End Sub

跟进

这将创建文件，如、Sample_1.txt等。根据您的要求修改它Sample_2.txtSample_3.txt

'~~> Change Title here
Const ppSTitle As String = "Title1"
'~~> Change File Name here
Const FlName As String = "C:\Sample"
'~~> Change Directory Here
Const sDir As String = "C:\Temp\"

Sub Sample()
    Dim ppPrsn As Presentation
    Dim ppSlide As Slide
    Dim filesize As Integer
    Dim shp As Shape
    Dim vFile
    Dim No As Long

    vFile = Dir(sDir & "*.ppt*")

    No = 1

    Do While vFile <> ""
        Set ppPrsn = Presentations.Open(FileName:=sDir & vFile)

        For Each ppSlide In ppPrsn.Slides
            If ppSlide.Shapes.Title.TextFrame.TextRange.Text = ppSTitle Then
                '~~> Get a free file handle
                filesize = FreeFile()

                '~~> Open your file
                Open FlName & "_" & No & ".txt" For Output As #filesize

                For Each shp In ppSlide.Shapes
                    If shp.HasTextFrame Then
                        If shp.TextFrame.HasText Then
                            '~~> Export Text
                            Print #filesize, shp.TextFrame.TextRange.Text
                        End If
                    End If
                Next

                Close #filesize

                No = No + 1
                Exit For
            End If
        Next

        ppPrsn.Close
        vFile = Dir
    Loop
    Set ppPrsn = Nothing
End Sub
于 2012-07-25T09:09:12.137 回答