最近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で保存するようにしています。
ソースコード
完成したツールのコードです。
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 |
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の起動と終了のコード。
【起動】
|
1 2 3 4 5 6 7 |
Dim wdApp As Word.Application Dim wdDoc As Word.Document Set wdApp = CreateObject("Word.Application") wdApp.Visible = True Set wdDoc = wdApp.Documents.Open(Wordファイル名) |
【終了】
|
1 2 3 4 |
wdDoc.Close wdApp.Visible = False Set wdApp = Nothing |
これだけです。
画像はInlineShape
Wordに貼り付けてある画像は、「InlineShape」オブジェクトらしいです。
「Shape」オブジェクトというのもあり、私は最初、Shapeオブジェクトを使ってやろうとしていました。
が、どうも画像を取得できていない・・・
ShapeとInlineShapeの違いがよく分からないけど、
とりあえずInlineShapeにしたら画像を取得できるようになりました。
私なりの解釈なので合っているか分かりませんが、
Shapeは文の途中に埋め込まれていない図形で、
InlineShapeは文の途中に埋め込まれている図形や画像なのかな、と。
InlineShapeで画像を選択してコピーしている部分のソースがこちらです。
|
1 2 3 4 5 6 7 |
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画像を右クリックで一発で保存できるのに、自動だとペイントを介さないといけないなんてバカげています。
が、他に方法がないので仕方なくペイントを使って画像を保存してみることにしました。
ペイントの起動部分のコードです。
|
1 2 3 4 5 6 7 8 |
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関数を使ってキー操作を行います。
|
1 2 3 4 5 6 7 8 |
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」で名前を付けて保存というコマンドに変えています。（閉じるも同様）
SendKeysは小文字じゃないと上手くいかない
一番最後にハマったのは貼り付け（Ctrl + V）の操作ができなかったこと。
保存などの他の操作はできていたので、何が悪いのか見当もつかず・・・・
そしたら、こんなQ&Aをみつけました。ドンピシャ。
https://q.hatena.ne.jp/1162662706
ようは、コマンドは大文字ではなく小文字でないといけなかったのです！
なぜ小文字？？？
理解不能ですが、小文字にしたらあっさりと実行できるようになりました。
×：SendKeys “^V”, 1000 ‘貼り付け Ctrl + V
〇：SendKeys “^v”, 1000 ‘貼り付け Ctrl + V
実行してみた
ツールを実行してみた動画です。
今回はWord文書内にある5枚の画像を保存してみました。
本当はもっと早くしたいけど、早くするときちんと画像が保存されないことがあったため、この速度で我慢しています。
いちいちペイントを介さないと保存できないなんて・・・
他にイイやり方がないものか。
VBAでWord操作するのは一筋縄ではいかない
Wordは同じOfficeだし、WordをVBAで操作するなんて簡単だろう
そう思っていた時期もありました。
しかし想像に反して手こずる手こずる…
どうして手動では右クリックでできる操作が自動だとできないのか？
不思議であります。
今回の「Word内の画像を一括保存する」は、なんとか自動化できたものの、
他の作業は自動化できるのかな？
不安です。
でも時間があるときにトライしてみます。
んじゃ、また～
コメント