2

複数のPowerPointファイルからtxtファイルまたはExcelファイルにテキストを抽出しようとしています。

問題は、特定のテキストタイトルのスライドのみを抽出しようとしていることです。いくつかのPowerPointファイルがあるので、エクスポートもいくつかの個別のファイルとして作成したいと思います。

これができるマクロを実行することは可能だと思いますが、完全にはわかりません。これは実際に可能ですか？もしそうなら、それをコーディングするための最良の方法は何ですか？

理論的には、これは単純な「IF」ステートメントである必要がありますが、私はVBAにあまり詳しくないか、慣れていません。

私は次のコードを使用しています:(コードの2番目のセット） http://www.pptfaq.com/FAQ00274_Export_Text_to_a_text_file-_extract_text_from_PowerPoint_-Mac_or_PC-.htm

このリンクと同様に:(コードの2番目のセットでもあります） VBAのパワーポイントファイルからすべてのテキストを抽出します

最初のリンクはテキストをtxtファイルに抽出しますが、特定のタイトルスライドを含むテキストを抽出することはできません。また、タイトルスライドを識別するコード行が含まれているようです。これは役立つようです。2番目のリンクは複数のtxtファイルをエクスポートできますが、出力txtファイルが空白です。つまり、機能させることができません。

そのようなものは、いくつかのPowerPoint内で大量のデータを並べ替えようとする人にとって役立つと確信しています。

誰かが素晴らしいアイデアを持っているなら！

ファローアップ

以下のコメントでの説明に従って、LIKE関数とワイルドカード（ "*"）関数を追加して、コードがスライドタイトル"Walkthrough：" +（単語walkthroughの後のすべて）を持つすべてのテキストを返すようにしました。同様の関数を追加しようとすると、.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

最初のリンクはテキストを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 に答える
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 に答える