PowerPointのテキストをtxt又はxlsx形式で出力するマクロ

PowerPointのテキストデータをファイルに出力したいと思ったことはありませんか?
本記事は、マクロを利用して、テキストファイル又はExcelファイルにテキストデータを出力する方法を説明します。

スポンサーリンク

本マクロを作った理由は情報カードを使うため

僕はこちらの記事に書いたように、パワーポイントを用いて情報カードを作成/管理しています。情報カードを使う理由は、眺めて思い付きを得たり、ブログの記事等の文章を書くためです。

ところが、情報カードからいざテキストにしようと思うと、パワーポイントからコピーして、Word等へペーストを繰り返すことになります。この作業は時間ばかりかかり、無駄です。

確かに「ファイル>エクスポート>配布資料の作成>配布資料の作成>アウトラインのみ」として、Wordに出力する機能はあります。でも、改行が多く、僕の用途には使いにくいです。

そこで今回、1スライドを1行にして、テキストファイル(拡張子:.xls)やExcelファイル(拡張子:xlsx)に出力するPowerPointのマクロを作りました。

マクロ

PowerPointのマクロはExcelとほとんど同じですので、使ったことのない方はまずこちらをどうぞ。

簡単な使い方は以下の通りです。コピーを取るなどしたファイルに対してお使いください。万一ファイルが壊れたとしても、僕は責任を取ることができません。

  1. ファイルを開く
  2. 「開発タブ」をクリック
  3. 「Visual Basic」をクリック
  4. プロジェクトエクスプローラ>「VBAProject(ファイル名.pptx)」を右クリック
  5. 「挿入」>「標準モジュール」
  6. マクロのコードをコピー&ペースト
  7. 「ツール」>「参照設定」
  8. 「Microsoft Excel xx.x Object Library」と「Windows Script Host Object Model」のチェックボックスをそれぞれチェック>「OK」をクリック(xx.xは、環境によって異なります。僕の環境では16.0でした)
  9. PowerPointに戻り、「マクロ」をクリック
  10. 「OutputToTextFile」又は「OutputToExcelFile」を選び、「実行」をクリック
  11. デスクトップにできるファイルを確認する
Option Explicit
'-----------------------------------------------------------------------
' Summary: 出力対象(Shape)があることの確認
' Output : intSlides: スライド数
'        : intShapes: 1スライド内のShapeの最大数
' Returns: True: 出力対象が有る, False: 出力対象が無い
'-----------------------------------------------------------------------
Private Function OutputTargetExists( _
        ByRef intSlides As Integer, _
        ByRef intShapes As Integer) _
        As Boolean

    ' --- 出力変数のクリアと暫定戻り値の設定 ---
    Const cstNone As Integer = 0    ' 見つからない
    ' スライドがまだ見つかっていない
    intSlides = cstNone
    ' Shapeもまだ見つかっていない
    intShapes = cstNone
    Dim blnTargetExists As Boolean  ' 戻り値
    ' 出力対象はまだ見つかっていない
    blnTargetExists = False

    ' --- スライドが1枚以上あることの確認 ---
    ' スライドが無ければばそのまま関数を抜ける
    If ActivePresentation.Slides.Count = cstNone Then GoTo PostProcess
    
    ' --- Shapeが1枚以上あることの確認 ---
    ' スライド数を変数にセット
    intSlides = ActivePresentation.Slides.Count
    Dim i As Integer            ' ループ変数
    ' スライドの1枚目から最後までループ
    For i = 1 To intSlides
        ' ページ内のShape数が現在の保持値より多ければ値を更新
        If ActivePresentation.Slides(i).Shapes.Count > intShapes Then
            intShapes = ActivePresentation.Slides(i).Shapes.Count
        End If
    Next i
    ' Shapeが1つ以上あればTrueをセット
    If intShapes > cstNone Then blnTargetExists = True

PostProcess:
    ' 戻り値のセット
    OutputTargetExists = blnTargetExists
End Function

'-----------------------------------------------------------------------
' Summary: スライドの内容をテキストファイルに出力する
' Remarks: Windows Script Host Object Model を参照設定する
'-----------------------------------------------------------------------
Public Sub OutputToTextFile()

    ' --- 出力対象(Shape)があることの確認 ---
    Dim intSlides As Integer ' スライド数
    Dim intShapes As Integer ' 1スライド内のShapeの最大数
    ' 出力対象が無ければ何もしないでサブルーチンを抜ける
    If OutputTargetExists(intSlides, intShapes) = False Then Exit Sub
    
    ' --- 出力ファイル名の設定 ---
    Dim strOutputFile As String ' 出力ファイル
    Dim wsh As New WshShell     ' Windows Script Host(Desktop指定の為)
    strOutputFile = wsh.SpecialFolders("Desktop") & "\" & _
            Left(ActivePresentation.Name, _
            InStrRev(ActivePresentation.Name, ".") - 1) & "_" & _
            Format(Now, "yyyymmdd_hhmmss") & ".txt"
    ' WSHの解放
    Set wsh = Nothing
    
    ' --- テキストファイルを出力モードで開く ---
    Dim intFile As Integer  ' ファイル番号
    ' フリーのファイル番号を得る
    intFile = FreeFile
    ' テキストファイルを出力モードで開く
    Open strOutputFile For Output As #intFile
    
    ' --- スライドの内容を書き出す ---
    ' スライドの1枚目から最後までループ
    Dim i As Integer    ' ループ変数
    For i = 1 To ActivePresentation.Slides.Count
        ' Shapeが存在したら出力対象とする
        If ActivePresentation.Slides(i).Shapes.Count > 0 Then
            Dim sglLoc() As Single      ' スライド内のShapeの位置
            Dim strContents() As String ' スライド内のShapeのテキスト
            ' スライド内のShapeの左上からの位置を保持する配列のサイズを確保
            ReDim sglLoc(1 To ActivePresentation.Slides(i).Shapes.Count)
            ' スライド内のShapeのテキストを保持する配列のサイズを確保
            ReDim strContents(1 To ActivePresentation.Slides(i).Shapes.Count)
            
            Dim j As Integer    ' ループ変数
            ' スライド内のShapeを順に調べる
            For j = 1 To ActivePresentation.Slides(i).Shapes.Count
                Dim shp As Shape    ' Shepeオブジェクト
                ' Shapeオブジェクトをインスタンス
                Set shp = ActivePresentation.Slides(i).Shapes(j)
                ' 左上からの距離を配列に保持
                sglLoc(j) = shp.Left + shp.Top
                ' Shapeにテキストがあることを確認
                If shp.TextFrame.HasText = msoTrue Then
                    ' テキストを保持(改行コード(Cr)は空白文字列に置換)
                    strContents(j) = _
                            Replace(shp.TextFrame.TextRange.Text, vbCr, " ")
                End If
            Next j
            ' Shapeの数が複数であれば、左上からの距離に応じてソートする
            If ActivePresentation.Slides(i).Shapes.Count >= 1 Then
                Dim sglTmp As Single    ' 距離用の一時的変数
                Dim strTmp As String    ' テキスト用の一時的変数
                Dim k As Integer        ' ループ変数
                ' 左上からの距離に応じてソート
                For k = LBound(sglLoc) To UBound(sglLoc) - 1
                    For j = k + 1 To UBound(sglLoc)
                        If sglLoc(k) > sglLoc(j) Then
                            ' 距離変数の交換
                            sglTmp = sglLoc(k)
                            sglLoc(k) = sglLoc(j)
                            sglLoc(j) = sglTmp
                            ' テキスト内容の交換
                            strTmp = strContents(k)
                            strContents(k) = strContents(j)
                            strContents(j) = strTmp
                        End If
                    Next j
                Next k
            End If
            Const cstDelimiter As String = vbTab    ' 出力の際のデリミタ
            ' 文字の間をデリミタで区切って出力
            Print #intFile, Join(strContents, cstDelimiter)
        End If
    Next i
    
    ' --- テキストファイルを閉じる ---
    Close #intFile
End Sub

'-----------------------------------------------------------------------
' Summary: スライドの内容をExcelファイルに出力する
' Remarks: Microsoft Excel xx.x Object Library と
'        : Windows Script Host Object Model    を参照設定する
'-----------------------------------------------------------------------
Public Sub OutputToExcelFile()

    ' --- 出力対象(Shape)があることの確認 ---
    Dim intSlides As Integer ' スライド数
    Dim intShapes As Integer ' 1スライド内のShapeの最大数
    ' 出力対象が無ければ何もしないでサブルーチンを抜ける
    If OutputTargetExists(intSlides, intShapes) = False Then Exit Sub
    
    ' --- 出力ファイル名の設定 ---
    Dim strOutputFile As String ' 出力ファイル
    Dim wsh As New WshShell     ' Windows Script Host(Desktop指定の為)
    strOutputFile = wsh.SpecialFolders("Desktop") & "\" & _
            Left(ActivePresentation.Name, _
            InStrRev(ActivePresentation.Name, ".") - 1) & "_" & _
            Format(Now, "yyyymmdd_hhmmss") & ".xlsx"
    ' WSHの解放
    Set wsh = Nothing
    
    ' --- Excelに書き込むデータの準備 ---
    Dim vrt As Variant  ' 一括書き込みのためのVariant変数
    ' 一括書き込みのためのサイズを確保(値はOutputTargetExistsで得ている)
    ReDim vrt(1 To intSlides, 1 To intShapes)
    Dim i As Integer        ' ループ変数
    ' スライドの1枚目から最後までループ
    For i = 1 To ActivePresentation.Slides.Count
        Dim j As Integer    ' ループ変数
        ' スライド内のShapeを順に調べる
        For j = 1 To ActivePresentation.Slides(i).Shapes.Count
            Dim shp As Shape    ' Shepeオブジェクト
            ' Shapeオブジェクトをインスタンス
            Set shp = ActivePresentation.Slides(i).Shapes(j)
            ' Shapeにテキストがあることを確認
            If shp.TextFrame.HasText = msoTrue Then
                ' テキストを保持(改行コード(Cr)は空白文字列に置換)
                vrt(i, j) = Replace(shp.TextFrame.TextRange.Text, _
                        vbCr, " ")
            End If
        Next j
    Next i
    
    ' --- Excelファイルを出力モードで開く ---
    Dim xlApp   As New Excel.Application    ' Excelアプリケーション
    Dim xlBook  As Excel.Workbook           ' Excelブック
    ' ブックを追加
    Set xlBook = xlApp.Workbooks.Add
    Dim xlSheet As Excel.Worksheet          ' Excelシート
    ' シートをセット
    Set xlSheet = xlBook.Worksheets(1)
    ' シートにデータを一括入力
    xlSheet.Range(xlSheet.Cells(1, 1), _
            xlSheet.Cells(UBound(vrt, 1), UBound(vrt, 2))) = vrt
    ' シートを解放
    Set xlSheet = Nothing
    ' ワークブックが存在することの確認
    If xlBook Is Nothing = False Then
        ' ワークブックを保存
        Call xlBook.SaveAs(FileName:=strOutputFile)
        ' ワークブックを閉じる
        xlBook.Close
        ' ワークブックを解放
        Set xlBook = Nothing
    End If
    ' エクセルアプリケーションが存在することの確認
    If xlApp Is Nothing = False Then
        ' アプリケーションを停止する
        xlApp.Quit
        ' アプリケーションを解放する
        Set xlApp = Nothing
    End If
End Sub

マクロの簡単な解説

関数OutputTargetExistsについて

OutputTargetExistsという関数は、パワーポイントのファイルの中に、出力対象があることを調べます。Shapeが1つでもあれば、(そこにTextが無くても)出力対象があると判定します。

出力対象がないのに出力ファイルを作ることは、無駄なので、この関数を使ってファイル作成の是非を判断しています。

参照設定について

出力ファイルはデスクトップに作成します。
デスクトップのPathを得る場合、WshShellを使います。

Set wsh = WScript.CreateObject(“WScript.Shell”)

のように宣言する方法をよく見かけますが、「Windows Script Host Object Model」を参照設定して、

Dim wsh As New WshShell

として使うとインテリセンスが出てくるので、断然おすすめです。

Excelを使う場合に、「Microsoft Excel xx.x Object Library」を参照設定しているのも同じ理由です。

スライド内の出力順序について

テキストファイル出力では、左上から順に出力しました。

Excelファイル出力では、ShapeのID番号順に出力しました。

これらは、好みです。どちらか一方に揃えることもできます。

Shape内のテキストの改行について

1スライドを1行に収めるために、Shape内のテキストの改行コード(Cr)をReplace文で半角空白に置き換えています。

Shape間の区切りについて

テキストファイルでは、Shape間をTabで区切りました。

ExcelファイルではCellを変えました。

Excelファイルでは、配列に保持した値を一括入力しています。この方法の方が、Cellに値を次々に入力するよりも高速です。

出力例

情報カードの例

情報カードの例

このようなカードに対して出力した結果を示します。

テキストファイル出力の例

テキストファイル出力の例

こちらはテキストファイル出力の例です。メモ帳の「右端で折り返す」という設定にチェックを付けているので改行されていますが、1スライド分のテキストは1行で出力しています。

Excelファイル出力の例

Excelファイル出力の例

こちらはExcelファイル出力の例です。こちらも、「折り返して全体を表示する」という設定にチェックを付けているため、E列で折り返しが発生しています。

テキストファイルでは日付が先に示されていましたが、Excelファイルでは、タイトルが先に示されています。コードを変えれば、どちらの順序にも揃えることができます。

まとめ

マクロを利用して、テキストファイルとExcelファイルにテキストデータを出力する方法を示しました。250枚程度なら実行時間は約2秒でした。

今後、文章作成に活用したいと考えています。

コメント

タイトルとURLをコピーしました