帯

VBA PowerPoint文書からWord文書作成

のぶ

前回記事「VBA PowerPointのテキスト抽出」では、PowerPoint文書にVBAプログラムを組み込んで、スライド上で選択したテキストボックスなどから、テキストを抽出してクリップボードにコピーするツールを作成しました。

これはこれで、一度プログラムさえ組み込んでしまえば、必要な箇所のテキストを簡単に取り出せて便利なのですが、対象となるPowerPoint文書にいちいちプログラムを組み込む手間が発生します。

そこで今回は、PowerPoint文書とは独立した外部ツールとして作成します。

１．ツールのイメージ

ツールは、VBAプログラムを開発しやすいExcelで作成し、外部のPowerPoint文書からテキストやスライドイメージなどを抽出して、Word文書へ貼り付けるものとします。貼り付けるデータはチェックオプションで指定できるようにします。ツールの外観イメージは次のようになります。

ツールを使用してPowerPoint文書から作成されたWord文書のイメージは次のようなものとなります。PowerPoint文書からスライドイメージとスライド内のテキスト、ノートのテキストを抽出してWord文書に貼り付けます。

２．モジュール構成

今回、PowerPoint文書とWord文書の２つの文書を同時に扱うことになりますが、１つのモジュールに全ての処理を組み込むと、この関数はどっちの文書を扱う処理なのか、だんだん分からなくなってプログラムがごちゃごちゃしてきます。

そこで、次の３つのモジュールに分けて作成することにしました。
・Sheet1.cls　　　　　 メインモジュール
・ClassPowerPoint.cls   PowerPoint文書を扱うクラスモジュール
・ClassWord.cls　  　　Word文書を扱うクラスモジュール

３つのモジュールの関係イメージは次図となります。

それでは、さっそくツールを作成していきましょう。

３．新規ブック作成

Excelでツールを作成しますので、「01.新規ブック作成」記事を参考にしながら、新規ブックを作成します。
ファイル名は「PPTのWord文書作成.xlsm」とします。

４．チェックオプションの追加

オプション指定のためのチェックボックスを追加していきます。
「10.VBA PowerPoint文書フォント変更の仕上げ」記事の「チェックオプションの追加」を参考にして、シート上の適当な位置に５つのチェックボックスを追加し、「プロパティ」の内容を次のように設定します。

(オブジェクト名)：checkSlideNumber
Caption：スライド 番号

(オブジェクト名)：checkSlideImage
Caption：スライド イメージ

(オブジェクト名)：checkSlideText
Caption：スライド テキスト

(オブジェクト名)：checkSlideNote
Caption：スライド ノート

(オブジェクト名)：checkPageBreak
Caption：改頁

５．プログラム実行ボタンの追加

「03.フォント指定表と起動ボタンの作成」の記事を参考にして、シート上の適当な位置に２つのボタンを追加し、「プロパティ」の内容を次のように設定します。

(オブジェクト名)：buttonOpenPresentations
Caption：PPTのWord文書作成

(オブジェクト名)：buttonAbort
Caption：中止

６．モジュールの挿入

今回作成する３つのモジュールを挿入します。
「開発」タブの「Visual Basic」を選択して、「Visual Basic Editor」（以降VBEと略す）を開きます。（Alt＋F11キーでも開けます）

プロジェクトエクスプローラーで、「Sheet1 (Sheet1)」をダブルクリックして、Sheet1モジュールを挿入します。

次に、VBEメニューで「挿入」ー「クラス モジュール」を選択します。
２回操作して２つのクラスモジュールを挿入します。

挿入したクラスモジュールで、「プロパティ」の内容を次のように設定します。（VBEでプロパティウィンドウが表示されていない場合は、メニューの「表示」ー「プロパティ ウィンドウ」を選択して表示してください）

(オブジェクト名)：ClassPowerPoint

(オブジェクト名)：ClassWord

それでは、次にプログラムコードを示します。
・Sheet1モジュール（96行）
・ClassPowerPointモジュール（166行）
・ClassWordモジュール（83行）

７．プログラムコード（Sheet1モジュール）

Sheet1モジュール内のプログラムコード全体を次に示します。
これをVBEでSheet1モジュールに書き込んでください。

Option Explicit

Private bAbortFlag As Boolean

Private Sub buttonOpenPresentations_Click()
    Call StatusBar("準備中...")
    bAbortFlag = False
    Dim oPowerPoint As ClassPowerPoint: Set oPowerPoint = New ClassPowerPoint
    Dim oWord As ClassWord: Set oWord = New ClassWord

    Dim sFileName As Variant
    For Each sFileName In DialogFileName("PowerPoint", "*.ppt?")
        If IsAbort() Then Exit For

        oPowerPoint.OpenPresentation CStr(sFileName)
        oWord.NewDocument oPowerPoint.FullName & ".docx"

        Call PowerPointToWord(oPowerPoint, oWord)

        oWord.SaveDocument
        oWord.CloseDocument
        oPowerPoint.ClosePresentation
    Next sFileName
    
    Set oWord = Nothing
    Set oPowerPoint = Nothing

    MsgBox "終了!"
End Sub

Private Sub buttonAbort_Click()
    bAbortFlag = True
End Sub

Private Function IsAbort() As Boolean
    DoEvents
    IsAbort = bAbortFlag
End Function

Private Sub PowerPointToWord(oPowerPoint As ClassPowerPoint, oWord As ClassWord)
    Dim nSlideIndex As Long
    For nSlideIndex = 1 To oPowerPoint.SlidesCount
        If IsAbort() Then Exit For
        
        Call StatusBar(oPowerPoint.FileName & " p." & oPowerPoint.SlideNumber(nSlideIndex))
        
        If checkSlideNumber Then
            oWord.AddText "＜Slide." & oPowerPoint.SlideNumber(nSlideIndex) & "＞"
        End If
        
        If checkSlideImage Then
            oPowerPoint.SlideToClipboard nSlideIndex
            oWord.AddFromClipboard
            oWord.WriteLineLastShape
        End If
        
        If checkSlideText Then
            oWord.AddText "＜Text＞"
            oWord.AddText oPowerPoint.GetSlideText(nSlideIndex)
        End If
        
        If checkSlideNote Then
            oWord.AddText "＜Note＞"
            oWord.AddText oPowerPoint.GetSlideNote(nSlideIndex)
        End If
        
        If checkPageBreak Then
            If nSlideIndex < oPowerPoint.SlidesCount Then
                oWord.AddPageBreak
            End If
        End If
    Next nSlideIndex
End Sub

Private Function DialogFileName(sDescription As String, sExtensions As String) As Collection
    Const DIALOG_CANCEL = 0
    
    Set DialogFileName = New Collection
    With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = True
        .Filters.Clear
        .Filters.Add sDescription, sExtensions
        
        If .Show = DIALOG_CANCEL Then Exit Function
        
        Dim sFileName As Variant
        For Each sFileName In .SelectedItems
            DialogFileName.Add sFileName
        Next sFileName
    End With
End Function

Private Sub StatusBar(sMessage As String)
    Application.StatusBar = sMessage
    DoEvents
End Sub

８．プログラムコード（ClassPowerPointモジュール）

ClassPowerPointモジュール内のプログラムコード全体を次に示します。
これをVBEでClassPowerPointモジュールに書き込んでください。

プログラム作成が面倒な方向けにExcelファイルも添付します。（シート保護やプログラムのパスワードロックはしてありません）

Option Explicit

Private Type TextWithPosition
    nTop As Single
    nLeft As Single
    sText As String
End Type

Private oApplication As Object
Private oPresentation As Object
Private oTextWithPosition() As TextWithPosition

Private Sub Class_Initialize()
    Set oApplication = CreateObject("PowerPoint.Application")
    Set oPresentation = Nothing
End Sub

Private Sub Class_Terminate()
    If oApplication.Presentations.Count = 0 Then
        oApplication.Quit
        Set oApplication = Nothing
    End If
End Sub

Public Sub OpenPresentation(sFileName As String)
    Set oPresentation = oApplication.Presentations.Open(sFileName)
    oApplication.Visible = True
End Sub

Public Sub ClosePresentation()
    oPresentation.Close
    Set oPresentation = Nothing
End Sub

Public Property Get FullName() As String
    FullName = oPresentation.FullName
End Property

Public Property Get FileName() As String
    FileName = oPresentation.Name
End Property

Public Property Get SlidesCount() As Long
    SlidesCount = oPresentation.Slides.Count
End Property

Public Property Get SlideNumber(nSlideIndex As Long) As Long
    SlideNumber = oPresentation.Slides(nSlideIndex).SlideNumber
End Property

Public Sub SlideToClipboard(nSlideIndex As Long)
    oPresentation.Slides(nSlideIndex).Copy
End Sub

Public Function GetSlideText(nSlideIndex As Long) As String
    GetSlideText = GetText(oPresentation.Slides(nSlideIndex).Shapes)
End Function

Public Function GetSlideNote(nSlideIndex As Long) As String
    GetSlideNote = GetText(oPresentation.Slides(nSlideIndex).NotesPage.Shapes)
End Function

Private Function GetText(oShapes As Object) As String
    GetText = ""
    Erase oTextWithPosition
    
    Call ShapesLoop(oShapes)
    
    On Error GoTo ERROR_EXIT

    Call SortTextWithPosition

    Dim i As Long
    For i = LBound(oTextWithPosition) To UBound(oTextWithPosition)
        GetText = GetText & oTextWithPosition(i).sText & vbNewLine
    Next i
ERROR_EXIT:
End Function

Private Sub ShapesLoop(oShapes As Object)
    Dim oShape As Object
    For Each oShape In oShapes
        If oShape.Type = msoGroup Then
            Call ShapesLoop(oShape.GroupItems)
        ElseIf oShape.Type = msoAutoShape Then
            Call ShapeToTextWithPosition(oShape)
        ElseIf oShape.HasSmartArt Then
            Call ShapesLoop(oShape.GroupItems)
        ElseIf oShape.HasChart Then
            Call ChartToTextWithPosition(oShape)
        ElseIf oShape.HasTable Then
            Call TableToTextWithPosition(oShape)
        Else
            Call ShapeToTextWithPosition(oShape)
        End If
    Next oShape
End Sub

Private Sub ShapeToTextWithPosition(oShape As Object)
    On Error Resume Next
    Dim sText As String: sText = ""
    sText = oShape.TextFrame2.TextRange.Text
    If Trim(sText) = "" Then Exit Sub
    On Error GoTo 0
    
    Call AddTextWithPosition(oShape.Top, oShape.Left, sText)
End Sub

Private Sub ChartToTextWithPosition(oShape As Object)
    Dim sText As String: sText = oShape.Chart.ChartTitle.Text
    If Trim(sText) = "" Then Exit Sub
    
    Call AddTextWithPosition(oShape.Top, oShape.Left, sText)
End Sub

Private Sub TableToTextWithPosition(oShape As Object)
    Dim sText As String: sText = ""
    Dim oRow As Object
    For Each oRow In oShape.Table.Rows
        Dim oCell As Object
        For Each oCell In oRow.Cells
            sText = sText & oCell.Shape.TextFrame2.TextRange.Text & vbTab
        Next oCell
        sText = Left(sText, Len(sText) - Len(vbTab))
        sText = sText & vbNewLine
    Next oRow
    sText = Left(sText, Len(sText) - Len(vbNewLine))
    
    Call AddTextWithPosition(oShape.Top, oShape.Left, sText)
End Sub

Private Sub AddTextWithPosition(nTop As Single, nLeft As Single, sText As String)
    On Error Resume Next
    Dim nLastIndex As Long: nLastIndex = 0
    nLastIndex = UBound(oTextWithPosition) + 1
    On Error GoTo 0
    
    ReDim Preserve oTextWithPosition(nLastIndex)
    
    With oTextWithPosition(nLastIndex)
        .nTop = nTop
        .nLeft = nLeft
        .sText = sText
    End With
End Sub

Private Sub SortTextWithPosition()
    Dim i As Long, j As Long
    For i = LBound(oTextWithPosition) To UBound(oTextWithPosition)
        For j = UBound(oTextWithPosition) To i Step -1
            Dim bSwap As Boolean
            If oTextWithPosition(i).nTop = oTextWithPosition(j).nTop Then
                bSwap = (oTextWithPosition(i).nLeft > oTextWithPosition(j).nLeft)
            Else
                bSwap = (oTextWithPosition(i).nTop > oTextWithPosition(j).nTop)
            End If
            
            If bSwap Then
                Dim oTemporary As TextWithPosition
                oTemporary = oTextWithPosition(i)
                oTextWithPosition(i) = oTextWithPosition(j)
                oTextWithPosition(j) = oTemporary
            End If
        Next j
    Next i
End Sub

９．プログラムコード（ClassWordモジュール）

ClassWordモジュール内のプログラムコード全体を次に示します。
これをVBEでClassWordモジュールに書き込んでください。

Option Explicit

Private oApplication As Object
Private oDocument As Object

Private Sub Class_Initialize()
    On Error Resume Next
    Set oApplication = GetObject(Class:="Word.Application")
    If oApplication Is Nothing Then     'Wordアプリ未起動
        Set oApplication = CreateObject("Word.Application")
    End If
    On Error GoTo 0
    
    oApplication.Options.CheckGrammarAsYouType = False  '自動文章校正オフ
End Sub

Private Sub Class_Terminate()
    If oApplication.Documents.Count = 0 Then
        oApplication.Quit
        Set oApplication = Nothing
    End If
End Sub

Public Function NewDocument(sFileName As String) As Object
    Set oDocument = oApplication.Documents.Add
    oApplication.Visible = True
    oDocument.SaveAs FileName:=sFileName
End Function

Public Function SaveDocument()
    oDocument.Save
End Function

Public Function CloseDocument()
    oDocument.Close
    Set oDocument = Nothing
End Function

Public Sub AddPageBreak()
    Const wdPageBreak = 7
    
    With oDocument.Paragraphs.Last
        .Range.InsertBreak Type:=wdPageBreak
    End With
End Sub

Public Sub AddText(sText As String)
    With oDocument.Paragraphs.Last
        .Range.Text = sText
    End With
    oDocument.Paragraphs.Add
End Sub

Public Sub AddFromClipboard()
    Dim nRetry As Integer
    For nRetry = 0 To 3     '貼り付けエラー時は3回までリトライ
        DoEvents
        If PasteFromClipboard(oDocument.Paragraphs.Last) Then Exit For
    Next nRetry
    oDocument.Paragraphs.Add
End Sub

Private Function PasteFromClipboard(oParagraph As Object) As Boolean
    Const wdPasteDefault = 0
    
    PasteFromClipboard = False
    On Error GoTo ERROR_EXIT
    oParagraph.Range.PasteAndFormat wdPasteDefault
    PasteFromClipboard = True
ERROR_EXIT:
End Function

Public Sub WriteLineLastShape()
    Dim oShape As Object
    Set oShape = oDocument.InlineShapes(oDocument.InlineShapes.Count)
    
    With oShape.Line
        .Style = msoLineSingle
        .DashStyle = msoLineSolid
        .Weight = 0.5
        .ForeColor.RGB = RGB(0, 0, 0)   '黒色
    End With
End Sub

１０．プログラムの動作確認

適当なPowerPoint文書を準備します。そして、ツールのチェックオプションを全てチェックして、「PPTのWord文書作成」ボタンを押してプログラムを実行します。
PowerPointとWordのアプリケーションが起動された後、ファイルダイアログが開くので、対象のPowerPoint文書を指定します。（複数ファイルを指定可）
対象のPowerPoint文書から、スライドイメージやスライド内のテキスト、ノートのテキストが抽出されてWord文書に貼り付けられます。
Word文書のファイル名は、対象のPowerPoint文書ファイル名＋".docx"とし、PowerPoint文書ファイルと同じフォルダ内に保存されます。
「終了!」メッセージボックスが表示されたら動作は正常です。「OK」ボタンを押してメッセージボックスを閉じます。
プログラム実行途中のイメージです。

チェックオプションでチェックを外すと抽出対象から除外されます。
オプション指定を色々と試してみましょう。

１１．プログラムの解説（Sheet1モジュール）

Sheet1モジュールのプログラムの主な内容を説明します。

モジュール変数のbAbortFlagは、処理の中止要求を示すフラグです。初期値は「False」ですが、「中止」ボタンが押された時に「True」に変更されます。

Private bAbortFlag As Boolean

buttonOpenPresentations_Clickは、PPTのWord文書作成ボタンが押されたときに実行される処理です。
Excelウィンドウのステータスバーに「準備中...」と表示後、bAbortFlag変数を初期化します。そして、PowerPointクラスとWordクラスのインスタンスを生成します。

Private Sub buttonOpenPresentations_Click()
    Call StatusBar("準備中...")
    bAbortFlag = False
    Dim oPowerPoint As ClassPowerPoint: Set oPowerPoint = New ClassPowerPoint
    Dim oWord As ClassWord: Set oWord = New ClassWord
    ：
    Set oWord = Nothing
    Set oPowerPoint = Nothing
    
    MsgBox "終了!"
End Sub

ファイルダイアログで選択された文書ファイルのファイル名を１つずつ取り出して処理するForループです。なお、「中止」ボタンが押された時には、IsAbort関数の戻り値がTrueとなるのでForループを抜けて処理を中止します。

    Dim sFileName As Variant
    For Each sFileName In DialogFileName("PowerPoint", "*.ppt?")
        If IsAbort() Then Exit For
        ：
    Next sFileName

ファイル名sFileNameで指定されたPowerPointの文書ファイルを開きます。
Word文書を新規作成して、そのファイル名はPowerPointの文書ファイル名に".docx"を付加したものとします。
PowerPointToWordで、PowerPoint文書の内容をWord文書に貼り付けます。
その後、Word文書を保存して閉じて、PowerPoint文書も閉じます。

        oPowerPoint.OpenPresentation CStr(sFileName)
        oWord.NewDocument oPowerPoint.FullName & ".docx"
        
        Call PowerPointToWord(oPowerPoint, oWord)
        
        oWord.SaveDocument
        oWord.CloseDocument
        oPowerPoint.ClosePresentation

buttonAbort_Clickは、「中止」ボタンが押された時に呼び出され、中止フラグ変数bAbortFlagにTrueを設定します。
IsAbortは、「中止」ボタンが押されたかどうかを返します。Forループ内で検定させて、中止の場合にループを抜けることで処理を中止できます。DoEventsは、OSに制御を移してボタンのクリックイベントを受け取りやすくします。

Private Sub buttonAbort_Click()
    bAbortFlag = True
End Sub

Private Function IsAbort() As Boolean
    DoEvents
    IsAbort = bAbortFlag
End Function

PowerPointToWordは、PowerPoint文書の内容をWord文書に貼り付ける処理です。PowerPoint文書の全てのスライドをForループで１枚ずつ処理します。Excelウィンドウのステータスバーには、PowerPoint文書ファイル名と処理中のスライド番号を表示します。

Private Sub PowerPointToWord(oPowerPoint As ClassPowerPoint, oWord As ClassWord)
    Dim nSlideIndex As Long
    For nSlideIndex = 1 To oPowerPoint.SlidesCount
        If IsAbort() Then Exit For
        
        Call StatusBar(oPowerPoint.FileName & " p." & oPowerPoint.SlideNumber(nSlideIndex))
        ：
    Next nSlideIndex
End Sub

スライド番号のオプションがチェックされていた場合は、スライド番号をWord文書に追加します。

        If checkSlideNumber Then
            oWord.AddText "＜Slide." & oPowerPoint.SlideNumber(nSlideIndex) & "＞"
        End If

スライドイメージのオプションがチェックされていた場合は、スライドイメージをクリップボードを介してWord文書に追加します。また、貼り付けたスライドイメージに枠線を描きます。

        If checkSlideImage Then
            oPowerPoint.SlideToClipboard nSlideIndex
            oWord.AddFromClipboard
            oWord.WriteLineLastShape
        End If

スライドテキストのオプションがチェックされていた場合は、スライドからテキストを抽出してWord文書に貼り付けます。

        If checkSlideText Then
            oWord.AddText "＜Text＞"
            oWord.AddText oPowerPoint.GetSlideText(nSlideIndex)
        End If

スライドノートのオプションがチェックされていた場合は、スライドからノートのテキストを抽出してWord文書に貼り付けます。

        If checkSlideNote Then
            oWord.AddText "＜Note＞"
            oWord.AddText oPowerPoint.GetSlideNote(nSlideIndex)
        End If

改頁のオプションがチェックされていて、最終頁でない場合は、改頁をWord文書に追加します。

        If checkPageBreak Then
            If nSlideIndex < oPowerPoint.SlidesCount Then
                oWord.AddPageBreak
            End If
        End If

DialogFileNameは、ファイルダイアログを表示して、選択されたファイル名をCollection戻り値として返します。.AllowMultiSelect = Trueとすることで複数ファイル選択が可能となります。

Private Function DialogFileName(sDescription As String, sExtensions As String) As Collection
    Const DIALOG_CANCEL = 0
    
    Set DialogFileName = New Collection
    With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = True
        .Filters.Clear
        .Filters.Add sDescription, sExtensions
        
        If .Show = DIALOG_CANCEL Then Exit Function
        
        Dim sFileName As Variant
        For Each sFileName In .SelectedItems
            DialogFileName.Add sFileName
        Next sFileName
    End With
End Function

StatusBarは、指定メッセージをExcelウィンドウのステータスバーに表示します。

Private Sub StatusBar(sMessage As String)
    Application.StatusBar = sMessage
    DoEvents
End Sub

１２．プログラムの解説（ClassPowerPointモジュール）

ClassPowerPointモジュールのプログラムの主な内容を説明します。

TextWithPositionは、テキストボックスの左上の位置情報とテキストを格納するユーザー定義型を宣言して、動的配列変数として宣言します。
oApplicationは、PowerPointアプリケーションの参照を格納する変数です。
oPresentationは、PowerPoint文書の参照を格納する変数です。

Private Type TextWithPosition
    nTop As Single
    nLeft As Single
    sText As String
End Type

Private oApplication As Object
Private oPresentation As Object
Private oTextWithPosition() As TextWithPosition

Class_Initializeは、クラスのインスタンスが生成されたときに呼ばれ、PowerPointアプリケーションを起動します。oPresentationは、まだPowerPoint文書を開いていないので、Nothingとしておきます。

Private Sub Class_Initialize()
    Set oApplication = CreateObject("PowerPoint.Application")
    Set oPresentation = Nothing
End Sub

Class_Terminateは、クラスのインスタンスが破棄されたときに呼ばれ、開いているPowerPoint文書ファイルがなければ、PowerPointアプリケーションを終了します。

Private Sub Class_Terminate()
    If oApplication.Presentations.Count = 0 Then
        oApplication.Quit
        Set oApplication = Nothing
    End If
End Sub

OpenPresentationは、PowerPoint文書ファイルを開き、PowerPointアプリケーションを表示します。

Public Sub OpenPresentation(sFileName As String)
    Set oPresentation = oApplication.Presentations.Open(sFileName)
    oApplication.Visible = True
End Sub

ClosePresentationは、PowerPoint文書ファイルを閉じます。

Public Sub ClosePresentation()
    oPresentation.Close
    Set oPresentation = Nothing
End Sub

FullNameは、PowerPoint文書ファイル名を絶対パスで返します。
FileNameは、PowerPoint文書ファイル名を返します。
SlidesCountは、スライド総数を返します。
SlideNumberは、指定スライドのスライド番号を返します。

Public Property Get FullName() As String
    FullName = oPresentation.FullName
End Property

Public Property Get FileName() As String
    FileName = oPresentation.Name
End Property

Public Property Get SlidesCount() As Long
    SlidesCount = oPresentation.Slides.Count
End Property

Public Property Get SlideNumber(nSlideIndex As Long) As Long
    SlideNumber = oPresentation.Slides(nSlideIndex).SlideNumber
End Property

SlideToClipboardは、指定スライドのイメージをクリップボードへコピーします。

Public Sub SlideToClipboard(nSlideIndex As Long)
    oPresentation.Slides(nSlideIndex).Copy
End Sub

GetSlideTextは、指定スライドのテキストを抽出して返します。

Public Function GetSlideText(nSlideIndex As Long) As String
    GetSlideText = GetText(oPresentation.Slides(nSlideIndex).Shapes)
End Function

GetSlideNoteは、指定スライドのノートのテキストを抽出して返します。

Public Function GetSlideNote(nSlideIndex As Long) As String
    GetSlideNote = GetText(oPresentation.Slides(nSlideIndex).NotesPage.Shapes)
End Function

GetTextは、指定スライド全体からテキストを抽出して並び替えた上で返します。ShapesLoopは、oShapesから抽出したテキストをoTextWithPositionへ格納します。SortTextWithPositionでoTextWithPosition配列変数の内容を位置情報を元に並び替えを行います。oTextWithPositionの先頭から順番にテキストを取り出し、改行文字を追加しながら連結します。

Private Function GetText(oShapes As Object) As String
    GetText = ""
    Erase oTextWithPosition
    
    Call ShapesLoop(oShapes)
    
    On Error GoTo ERROR_EXIT
    
    Call SortTextWithPosition
    
    Dim i As Long
    For i = LBound(oTextWithPosition) To UBound(oTextWithPosition)
        GetText = GetText & oTextWithPosition(i).sText & vbNewLine
    Next i
ERROR_EXIT:
End Function

ShapesLoopは、ShapesからShapeを１つずつForループで取り出して処理します。

Private Sub ShapesLoop(oShapes As Object)
    Dim oShape As Object
    For Each oShape In oShapes
    ：
    Next oShape
End Sub

Shape.TypeがmsoGroupの時はグループ化されたShapeなので、oShape.GroupItemsを引数として、自身の関数ShapesLoopを再帰呼び出しして、グループ化されたShapeを分解します。

        If oShape.Type = msoGroup Then
            Call ShapesLoop(oShape.GroupItems)

Shape.TypeがmsoAutoShapeの時は、そのShapeからテキストを抽出してTextWithPositionに格納します。

        ElseIf oShape.Type = msoAutoShape Then
            Call ShapeToTextWithPosition(oShape)

Shape.HasSmartArtがTrueの時はSmartArtなので、上記のグループ化されたShapeと同様に、自身の関数ShapesLoopを再帰呼び出しして、グループ化されたShapeを分解します。
単純にSmartArtを挿入した場合は、Shape.TypeがmsoSmartArtとなりますが、プレースホルダーにSmartArtを組み込んだ場合は、Shape.TypeがmsoPlaceHolderとなり区別がつかないため、HasSmartArtプロパティの方をチェックします。

        ElseIf oShape.HasSmartArt Then
            Call ShapesLoop(oShape.GroupItems)

Shape.HasChartがTrueの時はグラフなので、ChartToTextWithPosition関数を呼び出します。

        ElseIf oShape.HasChart Then
            Call ChartToTextWithPosition(oShape)

Shape.HasTableがTrueの時は表テーブルなので、TableToTextWithPosition関数を呼び出します。

        ElseIf oShape.HasTable Then
            Call TableToTextWithPosition(oShape)

上記以外の場合、そのShapeからテキストを抽出してTextWithPositionに格納します。単純なテキストボックスなどの場合にこの条件に来ます。

        Else
            Call ShapeToTextWithPosition(oShape)
        End If

ShapeToTextWithPositionは、Shapeからテキストを抽出してTextWithPositionに格納します。
直線などのテキストを含まないShapeの場合も呼び出されてくるので、「On Error Resume Next」でエラーが発生した処理はパスするようにします。
oShape.TextFrame2.TextRange.TextプロパティでテキストをsTextに取り出します。Textプロパティにアクセスできずエラーとなった場合はsTextが空文字のままとなります。
sTextの前後のスペースをTrimで削除した上で、空文字となった場合は、そのテキストは処理対象から外します。
AddTextWithPosition関数でテキストをTextWithPosition配列に格納します。

Private Sub ShapeToTextWithPosition(oShape As Object)
    On Error Resume Next
    Dim sText As String: sText = ""
    sText = oShape.TextFrame2.TextRange.Text
    If Trim(sText) = "" Then Exit Sub
    On Error GoTo 0
    
    Call AddTextWithPosition(oShape.Top, oShape.Left, sText)
End Sub

ChartToTextWithPositionは、グラフを処理する関数です。
グラフの場合は、そのタイトル名を抽出します。

Private Sub ChartToTextWithPosition(oShape As Object)
    Dim sText As String: sText = oShape.Chart.ChartTitle.Text
    If Trim(sText) = "" Then Exit Sub
    
    Call AddTextWithPosition(oShape.Top, oShape.Left, sText)
End Sub

TableToTextWithPositionは、表テーブルを処理する関数です。
Forループでテーブルから行データを取り出し、さらに行データからセルを取り出しながら、各セルのテキストを抽出します。
同一行内のセルのテキスト間はタブ文字で連結します。行末尾のタブ文字は余計なので削除した上で改行文字を付加します。最終行の末尾の改行文字は余計なので削除します。

Private Sub TableToTextWithPosition(oShape As Object)
    Dim sText As String: sText = ""
    Dim oRow As Object
    For Each oRow In oShape.Table.Rows
        Dim oCell As Object
        For Each oCell In oRow.Cells
            sText = sText & oCell.Shape.TextFrame2.TextRange.Text & vbTab
        Next oCell
        sText = Left(sText, Len(sText) - Len(vbTab))
        sText = sText & vbNewLine
    Next oRow
    sText = Left(sText, Len(sText) - Len(vbNewLine))
    
    Call AddTextWithPosition(oShape.Top, oShape.Left, sText)
End Sub

AddTextWithPositionは、Shapeの左上の位置情報とテキストを、oTextWithPosition配列を拡張して末尾に格納します。
oTextWithPosition配列が初期状態で空の場合は、UBound(oTextWithPosition)がエラーとなり、nLastIndexが初期値の0のままとなるので、ReDim Preserve oTextWithPosition(nLastIndex)で配列が１つ確保されます。
それ以降は、現状の配列数に１を加算して配列を拡張します。

Private Sub AddTextWithPosition(nTop As Single, nLeft As Single, sText As String)
    On Error Resume Next
    Dim nLastIndex As Long: nLastIndex = 0
    nLastIndex = UBound(oTextWithPosition) + 1
    On Error GoTo 0
    
    ReDim Preserve oTextWithPosition(nLastIndex)
    
    With oTextWithPosition(nLastIndex)
        .nTop = nTop
        .nLeft = nLeft
        .sText = sText
    End With
End Sub

SortTextWithPositionは、oTextWithPosition配列内の位置情報で、スライドの上から下の順番に、また上下位置が同じ場合は左から右の順番になるように配列内容を並び替えます。

Private Sub SortTextWithPosition()
    Dim i As Long, j As Long
    For i = LBound(oTextWithPosition) To UBound(oTextWithPosition)
        For j = UBound(oTextWithPosition) To i Step -1
            Dim bSwap As Boolean
            If oTextWithPosition(i).nTop = oTextWithPosition(j).nTop Then
                bSwap = (oTextWithPosition(i).nLeft > oTextWithPosition(j).nLeft)
            Else
                bSwap = (oTextWithPosition(i).nTop > oTextWithPosition(j).nTop)
            End If
            
            If bSwap Then
                Dim oTemporary As TextWithPosition
                oTemporary = oTextWithPosition(i)
                oTextWithPosition(i) = oTextWithPosition(j)
                oTextWithPosition(j) = oTemporary
            End If
        Next j
    Next i
End Sub

１３．プログラムの解説（ClassWordモジュール）

ClassWordモジュールのプログラムの主な内容を説明します。

oApplicationは、Wordアプリケーションの参照を格納する変数です。
oDocumentは、Word文書の参照を格納する変数です。

Private oApplication As Object
Private oDocument As Object

Class_Initializeは、クラスのインスタンスが生成されたときに呼ばれ、Wordアプリケーションの参照をoApplicationに設定します。Wordアプリケーションがすでに起動している場合は、その参照を取得して、未起動ならWordアプリケーションを起動します。

Private Sub Class_Initialize()
    On Error Resume Next
    Set oApplication = GetObject(Class:="Word.Application")
    If oApplication Is Nothing Then     'Wordアプリ未起動
        Set oApplication = CreateObject("Word.Application")
    End If
    On Error GoTo 0
    
    oApplication.Options.CheckGrammarAsYouType = False  '自動文章校正オフ
End Sub

Class_Terminateは、クラスのインスタンスが破棄されたときに呼ばれ、開いているWord文書ファイルがなければ、Wordアプリケーションを終了します。

Private Sub Class_Terminate()
    If oApplication.Documents.Count = 0 Then
        oApplication.Quit
        Set oApplication = Nothing
    End If
End Sub

NewDocumentは、Word文書を新規作成して、指定のファイル名を付けて一旦保存します。

Public Function NewDocument(sFileName As String) As Object
    Set oDocument = oApplication.Documents.Add
    oApplication.Visible = True
    oDocument.SaveAs FileName:=sFileName
End Function

SaveDocumentは、Word文書を上書き保存します。

Public Function SaveDocument()
    oDocument.Save
End Function

CloseDocumentは、Word文書を閉じます。

Public Function CloseDocument()
    oDocument.Close
    Set oDocument = Nothing
End Function

AddPageBreakは、Word文書の末尾に改頁を追加します。

Public Sub AddPageBreak()
    Const wdPageBreak = 7
    
    With oDocument.Paragraphs.Last
        .Range.InsertBreak Type:=wdPageBreak
    End With
End Sub

AddTextは、Word文書の末尾に指定のテキストを追加します。

Public Sub AddText(sText As String)
    With oDocument.Paragraphs.Last
        .Range.Text = sText
    End With
    oDocument.Paragraphs.Add
End Sub

AddFromClipboardは、クリップボードにコピーしたスライドイメージをWord文書の末尾に貼り付けます。実際の貼り付け処理は、PasteFromClipboard関数で行っていますが、貼り付けエラーが発生した場合は、３回までリトライするようにしています。

Public Sub AddFromClipboard()
    Dim nRetry As Integer
    For nRetry = 0 To 3     '貼り付けエラー時は3回までリトライ
        DoEvents
        If PasteFromClipboard(oDocument.Paragraphs.Last) Then Exit For
    Next nRetry
    oDocument.Paragraphs.Add
End Sub

Private Function PasteFromClipboard(oParagraph As Object) As Boolean
    Const wdPasteDefault = 0
    
    PasteFromClipboard = False
    On Error GoTo ERROR_EXIT
    oParagraph.Range.PasteAndFormat wdPasteDefault
    PasteFromClipboard = True
ERROR_EXIT:
End Function

本ツールの動作を確認しているときに、極まれにクリップボードからの貼り付け処理でエラーが発生して次図のメッセージが表示される現象に遭遇しました。
しかし、デバッグモードで処理を継続して、エラーとなった貼り付け処理を再度実行すると正常に処理が行われます。恐らく、スライドイメージをクリップボードへコピーする処理と、クリップボードから取り出して貼り付ける処理が非同期に動いているため、コピーが完了する前に取り出しが動き出すとエラーになると思われます。そのため、少し時間をあけて再度実行すると成功したのです。
このエラーを回避するには、コピー完了を待ってから取り出せばよいのですが、いつコピーが完了したのか、そのタイミングを取れません。
そこで、DoEventsをはさんで３回までリトライするようにしました。
実際に手元の環境で何度か動作確認をしましたが、エラーが発生しても１回目のリトライで正常に処理されました。環境によっては、３回のリトライでも貼り付けが出来ない場合があるかもしれません。その場合は、リトライ回数を増やす、あるいはSleepを入れるなどの対策が必要かもしれません。

WriteLineLastShapeは、Word文書の最後のShape（ここでは、最後に貼り付けたスライドイメージです）に黒色の実線枠を描く処理です。

Public Sub WriteLineLastShape()
    Dim oShape As Object
    Set oShape = oDocument.InlineShapes(oDocument.InlineShapes.Count)
    
    With oShape.Line
        .Style = msoLineSingle
        .DashStyle = msoLineSolid
        .Weight = 0.5
        .ForeColor.RGB = RGB(0, 0, 0)   '黒色
    End With
End Sub

さいごに

これで、PowerPoint文書からWord文書作成のツールは完成です。
最後までお読みいただきありがとうございました。
お気づきの点などありましたらコメント頂けますと幸いです。

記事を気に入って頂き、お役に立てたら嬉しいです。