ワード文書中の全画像を画像ファイルとして抽出するマクロ【図解】

このマクロは、ワード文書中のすべての画像を抽出するワードマクロ（Word VBA）です。

このマクロを実行すると、以下のイラストのように、ワード文書中のすべてのオブジェクト（画像、図形など）がpngファイルとして出力されます。

出力されたファイルはデスクトップ上に自動生成されるフォルダ内に格納されます。

\Word VBAを学べる貴重な一冊 /

マクロの全体の流れ

マクロの全体の流れを以下に示します。

step
1各自のワード文書を開きます

step
2左上に表示される本マクロのアイコンをクリックします

（アイコンの種類は各自が選べます。詳細は、後述の「マクロの使用準備」をご参照ください）

step
3「はい」を押して処理を開始します

「はい」を選択すると、自動で抽出処理が始まります。

進捗状況は、ワードファイルの左下に表示されます。

上のイラストの例では、１２７個のオブジェクトのうちの１７個目を処理しています。

処理が終わると、以下のようなメッセージが表示されます。

抽出ファイルは、デスクトップ上に自動作成されるフォルダの中に入っています。

フォルダ名は、「抽出元ワードファイル名_抽出オブジェクト」になります。

既に同じ名前のフォルダがある場合は、上書きせずに、末尾に枝番の付いたフォルダが新規に作成され、その中に抽出オブジェクトが格納されます。

step
4フォルダの中身を確認します

フォルダを開くと、以下のように抽出オブジェクトの画像ファイルが入っています。

抽出された画像ファイルの名前は、元のワードファイルに含まれていた順に末尾が001、002と連番になります。

以上が全体の流れです。

補足説明

本マクロは処理の一部でエクセル機能を使用します

本マクロは、処理の一部でエクセルの機能を使用します。

そのため、本マクロを実行するにはパソコンにエクセルがインストールされている必要があります。

白紙の画像ファイルが出力された場合

元のワードファイルに大量にオブジェクトが含まれている場合、多数出力される画像ファイルの中に、稀に白紙の画像ファイルが混ざる場合があります。

その場合は、再度抽出処理を実施して、その白紙の画像ファイルに対応する正常出力画像ファイルを取得してください。

（同じ画像や図形が再抽出処理で再び白紙ファイルとして出力されることは極めて稀のため、この対応法で対処可能です）

抽出元ワードファイルを開いた時にでるメッセージ

本マクロとは関係なく、一般的に、新たに入手／コピーしたワードファイルを開くと、以下のように「編集を有効にする」というボタンが表示される場合があります。

この場合は、「編集を有効にする」を押してから、本マクロを実行してください。

本マクロは、抽出元ワードファイルを変更するものではありませんが、本マクロがワードファイル中のオブジェクトにアクセスするには、「編集を有効にする」を押す必要があります。

また、本マクロはワードファイルを変更するものではありませんが、念のためワードファイルの事前バックアップをお願いします。

単純なオブジェクト

棒線のような単純なオブジェクトは、画像ファイルとして抽出されない場合があります。

この場合、抽出が成功したオブジェクトとしてカウントされてしまう場合があることだけご了承ください。

もっとも、棒線のような単純なオブジェクトの画像が必要な方はあまりいらっしゃらないとは思いますが。。

マクロの使用準備

以下の手順を行うと、各自のワードファイルから本マクロを呼び出せるようになります。

１．こちらの記事に記載したステップ①の手順０～６までを実施した後、ステップ①の手順７で、この記事の最後にあるコードを標準モジュールのＭodule1にコピペします。

２．こちらの記事に記載したステップ①の８から２２までを行います

（ステップ①の１１では、以下のマクロ名を選択してから、追加ボタンを押してください）

Project.Module1.ExtractObjects

ステップ①の１１で追加するのは、上記のマクロ名のみです。

（ステップ①の１３では、お好きなアイコンを選んでください）

（ステップ①の２０での保存名は何でもかまいません）

（ステップ①の２２の次に記載されている「動作確認」はスキップしていただいてもかまいません）

３．こちらの記事に記載したステップ②を行います

ステップ②を行うことで、このマクロをどのワード文書からも呼び出せるようになります。

（このステップ②を行うと、各自のワードファイルを開いた際に、各自が選んだマクロアイコンがワード文書の左上に表示されるようになります）

以上で、マクロを使用する準備が整いました！

マクロの削除

本マクロが不要になった場合は、こちらの手順でdotmファイルごと削除してください。

マクロのコード

以下は、本マクロのコードです。

上の説明にあるように標準モジュールにコピペしてご使用ください。

（以下のコードをすべて選択して、そのまま貼り付けてください）

現在の公開バージョンは、V01L01（公開日：2024/9/26）です。

Public skipedObjNumber As Integer

Sub ExtractObjects()
'V01L01
    Dim objFSO As Object
    Dim objFolder As Object
    Dim strFolderPath As String
    Dim strFolderName As String
    Dim i As Integer
    Dim intResponse As Integer
    Dim xlApp As Object
    Dim xlWb As Object
    Dim xlSheet As Object
    Dim shapeCount As Integer
    Dim totalShapes As Integer
    Dim processedObjects As Integer

    skipedObjNumber = 0

    ' 処理開始の確認メッセージを表示
    intResponse = MsgBox("オブジェクトの抽出処理を開始してよろしいですか？", vbYesNo + vbQuestion + vbDefaultButton2, "確認")
    If intResponse = vbNo Then
        Exit Sub
    End If

    ' オブジェクトの存在を確認
    If ActiveDocument.Shapes.Count = 0 And ActiveDocument.InlineShapes.Count = 0 Then
        MsgBox "この文書中にはオブジェクトが存在しません。処理を終了します。", vbInformation
        Exit Sub
    End If

    ' 抽出オブジェクトを格納するフォルダ名を設定
    strFolderName = ActiveDocument.Name & "_抽出オブジェクト"

    ' デスクトップ上に抽出オブジェクト用フォルダを作成
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    strFolderPath = Environ("USERPROFILE") & "\Desktop\" & strFolderName
    i = 1
    While objFSO.FolderExists(strFolderPath)
        i = i + 1
        strFolderPath = Environ("USERPROFILE") & "\Desktop\" & strFolderName & "_" & i
    Wend
    Set objFolder = objFSO.CreateFolder(strFolderPath)

    ' Excelアプリケーションを起動
    Set xlApp = CreateObject("Excel.Application")
    xlApp.Visible = False ' Excelの表示を隠す
    Set xlWb = xlApp.Workbooks.Add
    Set xlSheet = xlWb.Sheets(1)

    ' 総オブジェクト数を取得
    totalShapes = ActiveDocument.Shapes.Count + ActiveDocument.InlineShapes.Count
    shapeCount = 0 ' 処理済みのオブジェクト数をカウント
    processedObjects = 0

    ' Shapesオブジェクトの処理
    shapeCount = shapeCount + ProcessShapes(ActiveDocument.Shapes, xlSheet, shapeCount, totalShapes, strFolderPath, processedObjects, xlApp, xlWb, xlSheet, False)

    ' InlineShapesオブジェクトの処理
    shapeCount = shapeCount + ProcessShapes(ActiveDocument.InlineShapes, xlSheet, shapeCount, totalShapes, strFolderPath, processedObjects, xlApp, xlWb, xlSheet, True)

    ' ステータスバーをクリア
    Application.StatusBar = totalShapes & "個中" & totalShapes - skipedObjNumber & "個のオブジェクトの抽出に成功しました。"

    ' Excelを終了
    xlWb.Close False
    xlApp.Quit

    MsgBox totalShapes & "個中" & totalShapes - skipedObjNumber & "個のオブジェクトの抽出に成功しました。", vbInformation

    ' オブジェクトの後処理
    Set objFolder = Nothing
    Set objFSO = Nothing
    Set xlApp = Nothing
    Set xlWb = Nothing
    Set xlSheet = Nothing

    ClearClipboard
End Sub

Function ProcessShapes(shapesCollection As Object, targetSheet As Object, shapeCount As Integer, totalShapes As Integer, strFolderPath As String, ByRef processedObjects As Integer, ByRef xlApp As Object, ByRef xlWb As Object, ByRef xlSheetVar As Object, isInline As Boolean) As Integer
    Dim shapeObj As Object
    Dim tempImagePaths(1 To 5) As String
    Dim largestImagePath As String
    Dim largestFileSize As Long
    Dim fileSize As Long
    Dim j As Integer
    Dim finalImagePath As String
    Dim retryCount As Integer
    Dim success As Boolean

    ' 各オブジェクトを処理
    For Each shapeObj In shapesCollection
        ' オブジェクトがShapesかInlineShapesかによって処理を分ける
        If isInline Then
            shapeObj.Range.Select
        Else
            shapeObj.Anchor.Select
        End If
        Selection.GoTo What:=wdGoToPage, Which:=wdGoToAbsolute, Count:=Selection.Information(wdActiveEndPageNumber)

        shapeCount = shapeCount + 1
        processedObjects = processedObjects + 1
        ' ステータスバーに進捗を表示
        Application.StatusBar = "処理中: " & shapeCount & " / " & totalShapes

        ' 5つのPNGファイルを作成し、保存先のパスを指定
        For j = 1 To 5
            retryCount = 0
            success = False
            Do While retryCount < 10 And Not success
                ' オブジェクトをコピーしてExcelにペースト
                shapeObj.Select

                Do While retryCount < 10
                    On Error Resume Next
                    Selection.Copy
                    If Err.Number = 0 Then Exit Do
                    retryCount = retryCount + 1
                    Err.Clear
                    Wait 0.2
                Loop
                On Error GoTo 0

                If retryCount = 10 Then
                    Application.StatusBar = "コピーが10回失敗しました。次のオブジェクトに移ります。"
                    GoTo NextShape
                End If

                DoEvents

                On Error Resume Next
                targetSheet.Paste
                If Err.Number <> 0 Then
                    Err.Clear ' エラーをクリア
                    Application.StatusBar = "処理中: " & shapeCount & " / " & totalShapes & "　オブジェクトのペースト中にエラーが発生しました。再試行します。" & "再試行" & retryCount + 1 & "回目"

                    retryCount = retryCount + 1
                    Wait 0.2
                Else
                    ' ファイルの保存
                    tempImagePaths(j) = strFolderPath & "\オブジェクト_" & Format(shapeCount, "000") & "_" & j & ".png"
                    SaveShapeAsImage targetSheet, tempImagePaths(j)

                    ' ファイルが正しく作成されたか確認
                    If Dir(tempImagePaths(j)) <> "" Then
                        success = True
                    Else
                        retryCount = retryCount + 1
                    End If
                End If
                On Error GoTo 0 ' エラーハンドリングをリセット
            Loop

            ' 作成が10回失敗した場合、次のシェイプに進む
            If retryCount = 10 Then
                Application.StatusBar = "ファイル生成が10回失敗しました。次のオブジェクトに移ります。"
                skipedObjNumber = skipedObjNumber + 1
                GoTo NextShape
            End If
        Next j

        ' シェイプを削除して次のオブジェクトへ
        targetSheet.Shapes(targetSheet.Shapes.Count).Delete
        Wait 0.2

        ' 最大サイズのファイルを探す
        largestFileSize = 0
        For j = 1 To 5 ' 5つのファイルの中から最大サイズを探す
            fileSize = FileLen(tempImagePaths(j))
            If fileSize > largestFileSize Then
                largestFileSize = fileSize
                largestImagePath = tempImagePaths(j)
            End If
        Next j

        ' 最大サイズのファイル以外を削除
        For j = 1 To 5 ' 5つのファイルを処理
            If tempImagePaths(j) <> largestImagePath Then
                On Error Resume Next
                If Dir(tempImagePaths(j)) <> "" Then
                    Kill tempImagePaths(j)
                End If
                On Error GoTo 0
            End If
        Next j

        ' 最終的なファイルのパスを設定
        finalImagePath = strFolderPath & "\オブジェクト_" & Format(shapeCount, "000") & ".png"

        ' ファイル名を変更
        On Error Resume Next
        Name largestImagePath As finalImagePath
        On Error GoTo 0

        ' 50個のオブジェクトごとにExcelを再起動してメモリを解放
        If processedObjects Mod 50 = 0 Then
            xlWb.Close False
            xlApp.Quit
            Set xlApp = Nothing
            Set xlWb = Nothing
            Set xlSheetVar = Nothing
            ClearClipboard
            Set xlApp = CreateObject("Excel.Application")
            xlApp.Visible = False
            Set xlWb = xlApp.Workbooks.Add
            Set xlSheetVar = xlWb.Sheets(1)
            Wait 2 ' 再起動後少し待機
        End If
        
NextShape:
    Next shapeObj

    ProcessShapes = shapeCount
End Function

Sub SaveShapeAsImage(xlSheet As Object, imagePath As String)
    Dim shapeObj As Object
    Dim tempChart As Object

    Set shapeObj = xlSheet.Shapes(xlSheet.Shapes.Count)

    shapeObj.Copy

    Set tempChart = xlSheet.ChartObjects.Add(0, 0, shapeObj.Width, shapeObj.Height)
    tempChart.Chart.Paste
    tempChart.Chart.Export FileName:=imagePath, FilterName:="PNG"

    tempChart.Delete
End Sub

Sub Wait(seconds As Single)
    Dim start As Single
    start = Timer
    Do While Timer < start + seconds
        DoEvents
    Loop
End Sub

Sub ClearClipboard()
    With CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
        .SetText ""
        .PutInClipboard
    End With
End Sub