Excel-VBAでWordの画像を一括保存する（ペイント使用、SendKeys操作）

2020年3月31日

URLをコピーしました！

最近Wordpressに記事を投稿するお仕事をちょくちょくしております。
その際、Wordで下書きされた記事を渡されるんです。
記事投稿の作業としては、ざっくりこんな流れ

1:Word内の画像を保存する
2:画像を圧縮する
3:Word文書をHTML化（文字装飾とか）
4:WordPressに画像をアップロード
5:HTML化した記事をWordPressに投稿

この作業をね、自動化したいと思っているんです。

で、今回は1番の「Word内の画像を保存する」を自動化させてみました。

ハッキリ言って、WordをVBAで操作するのは難ありです。
全部自動化は無理かも…

準備

VBAでWordを操作するための準備です。
といっても、参照設定を一つ追加するだけですが。

VBA参照設定

ExcelのVBAでWordを動かすためには参照設定をしないといけません。

「ツール」→「参照設定」で
「Microsoft Word ## Object Library」にチェックします。（##はOfficeのバージョンによります）

Word

Wordファイルはこのようになっています。
（今回は自分の過去記事をWordにしてみたのを使用します）

文書の途中で何枚か画像が埋め込まれています。

Word内の画像を一括保存するツール

Excel VBAで作ってみた、Word内の画像を一括保存するツールです。
Wordファイルの選択と、保存するフォルダの選択、ファイル名はあらかじめシートでやっておくようにしました。

また、画像のファイル名は「***0.png」「***1.png」と、指定した名前＋数字（０始まり）で、pngで保存するようにしています。

ソースコード

完成したツールのコードです。


Option Explicit


Sub main()
    
    Dim filename As String
    Dim fname As String
    Dim folder As String
    Dim cnt As Integer
    Dim wdApp As Word.Application
    Dim wdDoc As Word.Document
    Dim ishp As InlineShape
    
    filename = Range("D7").Text  '図のファイル名
    folder = Range("D8").Text    '図の保存場所
    
    'Word立ち上げ
    Set wdApp = CreateObject("Word.Application")
    wdApp.Visible = True
    
    
    Set wdDoc = wdApp.Documents.Open(Range("D5").Text)
    
    cnt = 0
    
    '図をコピーしてペイントで保存
    For Each ishp In wdDoc.InlineShapes
        wdDoc.Activate
        ishp.Select
        wdDoc.ActiveWindow.Selection.Copy
        fname = folder + "\" + filename + CStr(cnt)
        
        Call paint(fname)
        cnt = cnt + 1

    Next ishp

    wdDoc.Close
    wdApp.Visible = False
    Set wdApp = Nothing
    
    
    MsgBox ("終了")
End Sub

'図を保存するフォルダーを選択する
Sub selectFolder()
    Dim foldername As String
        
    ChDir ThisWorkbook.Path
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = ThisWorkbook.Path
        If .Show = True Then
            foldername = .SelectedItems(1)
            Range("D8") = foldername
        End If
    End With

End Sub

'ワードファイルを選択する
Sub selectWord()
    Dim ret As Variant
    
    ret = Application.GetOpenFilename("Wordファイル(*.docx),*.docx")
    
    If ret = False Then
        Exit Sub
    End If
    
    Range("D5") = CStr(ret)
    
End Sub

'ペイントを起動して図を貼り付け保存する
Sub paint(ByVal filename As String)
    Dim pnt
    'ペイント起動
    pnt = Shell("mspaint.exe", 1)
    Application.Wait Now + TimeValue("00:00:02")
    
    AppActivate pnt   'アクティベイト
    Application.Wait Now + TimeValue("00:00:01")
    
    '大文字だと上手くいかない　小文字で
    SendKeys "^v", 1000  '貼り付け Ctrl + V
    
    SendKeys "^+x", 1000   'トリミング Ctrl + Shift + X
    SendKeys "%fa", 1000  '名前を付けて保存 Alt + ファイル→a
    SendKeys filename, 1000 '保存先入力
    SendKeys "{Enter}", 1000
    SendKeys "%fx", 1000   '閉じる Alt + ファイル→x
    Application.Wait Now + TimeValue("00:00:02")
End Sub

このソースコードにたどり着くまでに、かなり紆余曲折しました。
そんな経緯を振り返りつつ、ソースコードのポイントを説明していきます。

Wordの起動、終了

まずは基本のWordの起動と終了のコード。

【起動】


Dim wdApp As Word.Application
Dim wdDoc As Word.Document

Set wdApp = CreateObject("Word.Application")
wdApp.Visible = True
Set wdDoc = wdApp.Documents.Open(Wordファイル名)

【終了】


wdDoc.Close
wdApp.Visible = False
Set wdApp = Nothing

これだけです。

※Wordが既に立ち上がっている場合はフリーズします。未対応です。

画像はInlineShape

Wordに貼り付けてある画像は、「InlineShape」オブジェクトらしいです。
「Shape」オブジェクトというのもあり、私は最初、Shapeオブジェクトを使ってやろうとしていました。
が、どうも画像を取得できていない・・・
ShapeとInlineShapeの違いがよく分からないけど、
とりあえずInlineShapeにしたら画像を取得できるようになりました。

私なりの解釈なので合っているか分かりませんが、
Shapeは文の途中に埋め込まれていない図形で、
InlineShapeは文の途中に埋め込まれている図形や画像なのかな、と。

InlineShapeで画像を選択してコピーしている部分のソースがこちらです。


For Each ishp In wdDoc.InlineShapes
         wdDoc.Activate
         ishp.Select
         wdDoc.ActiveWindow.Selection.Copy
　　　　　:
Next ishp

wdDoc.InlineShapes
でWord内の全画像が取得できます。

画像をコピーする際の注意点として
普通、SelectしたらSelection.Copyだけでいいはずなのですが、Wordだからなのかダメでした。
wdDoc.ActiveWindow.Selection.Copy
としないとコピーできません。

InlineShapeを保存する方法がない

InlineShapeなら画像を取得できるのですが、保存する関数がありませんでした。
Shapeオブジェクトなら保存する関数があるのですが。

途方にくれます…

InlineShapeをShapeに変換する関数があるので、それでShapeに変換して保存しようと試みたのですが、
なぜか上手くいかず。
原因不明です。

ペイントを起動して貼り付けて保存することにした

ツール作成に暗雲が立ち込める中、思いついたのがペイントに画像を貼り付けて保存する方法。

手作業でやるならWord画像を右クリックで一発で保存できるのに、自動だとペイントを介さないといけないなんてバカげています。
が、他に方法がないので仕方なくペイントを使って画像を保存してみることにしました。

ペイントの起動部分のコードです。


Dim pnt
'ペイント起動
pnt = Shell("mspaint.exe", 1)
Application.Wait Now + TimeValue("00:00:02")

AppActivate pnt   'アクティベイト
Application.Wait Now + TimeValue("00:00:01")

起動後とアクティベイト後に待ち時間を入れています。
待ち時間を入れないと、上手く画像が保存されなかったためです。

SendKeysでペイントを操作

VBAからペイントを操作するのに、SendKeys関数を使ってキー操作を行います。


SendKeys "^v", 1000  '貼り付け Ctrl + V
SendKeys "^+x", 1000   'トリミング Ctrl + Shift + X
SendKeys "%fa", 1000  '名前を付けて保存 Alt + ファイル→a
SendKeys filename, 1000 '保存先入力
SendKeys "{Enter}", 1000
SendKeys "%fx", 1000   '閉じる Alt + ファイル→x
Application.Wait Now + TimeValue("00:00:02")

今回は、

貼り付け(Ctrl + V)
トリミング（切り取り）(Ctrl + Shift + x)
名前を付けて保存(Alt + ファイル→a)
保存ファイル名入力
エンター
ペイントを閉じる(Alt + ファイル→x)

の順にコマンドを送るようにしました。
また、「,1000」の部分はコマンド送信後に1秒待つように指定しています。

SendKeysについてはこちらのページを参考にしました。
https://www.moug.net/tech/exvba/0150016.html

なお、いろんなサイトで「名前を付けて保存」を「F4→a」としているのですが、それだと上手くいかなかったので、「Alt＋f」で「ファイル」メニューを開いて「a」で名前を付けて保存というコマンドに変えています。（閉じるも同様）