PowerPointのテキストデータをファイルに出力したいと思ったことはありませんか？
本記事は、マクロを利用して、テキストファイル又はExcelファイルにテキストデータを出力する方法を説明します。
本マクロを作った理由は情報カードを使うため
僕はこちらの記事に書いたように、パワーポイントを用いて情報カードを作成／管理しています。情報カードを使う理由は、眺めて思い付きを得たり、ブログの記事等の文章を書くためです。
ところが、情報カードからいざテキストにしようと思うと、パワーポイントからコピーして、Word等へペーストを繰り返すことになります。この作業は時間ばかりかかり、無駄です。
確かに「ファイル＞エクスポート＞配布資料の作成＞配布資料の作成＞アウトラインのみ」として、Wordに出力する機能はあります。でも、改行が多く、僕の用途には使いにくいです。
そこで今回、１スライドを１行にして、テキストファイル（拡張子：.xls）やExcelファイル（拡張子：xlsx）に出力するPowerPointのマクロを作りました。
マクロ
PowerPointのマクロはExcelとほとんど同じですので、使ったことのない方はまずこちらをどうぞ。
簡単な使い方は以下の通りです。コピーを取るなどしたファイルに対してお使いください。万一ファイルが壊れたとしても、僕は責任を取ることができません。
- ファイルを開く
- 「開発タブ」をクリック
- 「Visual Basic」をクリック
- プロジェクトエクスプローラ＞「VBAProject（ファイル名.pptx）」を右クリック
- 「挿入」＞「標準モジュール」
- マクロのコードをコピー＆ペースト
- 「ツール」＞「参照設定」
- 「Microsoft Excel xx.x Object Library」と「Windows Script Host Object Model」のチェックボックスをそれぞれチェック＞「OK」をクリック（xx.xは、環境によって異なります。僕の環境では16.0でした）
- PowerPointに戻り、「マクロ」をクリック
- 「OutputToTextFile」又は「OutputToExcelFile」を選び、「実行」をクリック
- デスクトップにできるファイルを確認する
Option Explicit
'-----------------------------------------------------------------------
' Summary: 出力対象(Shape)があることの確認
' Output : intSlides: スライド数
' : intShapes: １スライド内の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
' --- スライドが１枚以上あることの確認 ---
' スライドが無ければばそのまま関数を抜ける
If ActivePresentation.Slides.Count = cstNone Then GoTo PostProcess
' --- Shapeが１枚以上あることの確認 ---
' スライド数を変数にセット
intSlides = ActivePresentation.Slides.Count
Dim i As Integer ' ループ変数
' スライドの１枚目から最後までループ
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が１つ以上あれば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 ' １スライド内の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
' --- スライドの内容を書き出す ---
' スライドの１枚目から最後までループ
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 ' １スライド内の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 ' ループ変数
' スライドの１枚目から最後までループ
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が１つでもあれば、（そこに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内のテキストの改行について
１スライドを１行に収めるために、Shape内のテキストの改行コード（Cr）をReplace文で半角空白に置き換えています。
Shape間の区切りについて
テキストファイルでは、Shape間をTabで区切りました。
ExcelファイルではCellを変えました。
Excelファイルでは、配列に保持した値を一括入力しています。この方法の方が、Cellに値を次々に入力するよりも高速です。
出力例
情報カードの例
このようなカードに対して出力した結果を示します。
テキストファイル出力の例
こちらはテキストファイル出力の例です。メモ帳の「右端で折り返す」という設定にチェックを付けているので改行されていますが、１スライド分のテキストは１行で出力しています。
Excelファイル出力の例
こちらはExcelファイル出力の例です。こちらも、「折り返して全体を表示する」という設定にチェックを付けているため、E列で折り返しが発生しています。
テキストファイルでは日付が先に示されていましたが、Excelファイルでは、タイトルが先に示されています。コードを変えれば、どちらの順序にも揃えることができます。
まとめ
マクロを利用して、テキストファイルとExcelファイルにテキストデータを出力する方法を示しました。250枚程度なら実行時間は約２秒でした。
今後、文章作成に活用したいと考えています。
コメント