このマクロは、ワード文書中のすべての画像を抽出するワードマクロ（Word VBA）です。
このマクロを実行すると、以下のイラストのように、ワード文書中のすべてのオブジェクト（画像、図形など）がpngファイルとして出力されます。
出力されたファイルはデスクトップ上に自動生成されるフォルダ内に格納されます。
マクロの全体の流れ
マクロの全体の流れを以下に示します。
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