使用基于幻灯片 Headers 的布尔值从多个powerpoint文件中提取文本

2 回答

• 1

  如果定义的字符串可用，则此代码将查看每个形状 .
  如果可用，它会使用Filesystem对象将形状包含的文本写入文本文件 .
  要使用它，您需要引用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
  

  回复于 2024-04-28T00:24:24+08:00
• 1

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

  这对我有用

  '~~> 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
  

  FOLLOWUP

  这将创建类似 Sample_1.txt ， Sample_2.txt ， Sample_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
  

  回复于 2024-04-28T00:24:24+08:00