画像をWordに貼って図表番号を付ける

# 概要
[アプリのスクリーンショットをpngファイルにする](https://qiita.com/int_main_void/items/66e74c1f63c6cc3c489f)の続き。

「[ExcelでスクリーンショットコレクションするならWordの方がいいよというお話](https://qiita.com/yosatonet/items/0a0edfbc8f75499ce532)」でコメントした

> 1. スクリーンショット画像をとったとき、Excelファイルに「ファイル名、キャプション、図表番号」のリストを作っておく。※キャプションは後から手入力する。
2. そのリストからWordのCOMオブジェクトを利用して「図の挿入～図表目次を自動で作成」する。
> 
> ・・・ということはできそうな気もする

の検証コード。

一応できた。


## 予定

- スクリーンショット取得自体は別記事で書いたので、画像がすでにあり、Excelファイルに「ファイル名、キャプション」が書いてある状態を前提として、Wordに貼り込むスクリプトに変更する予定
- 説明が難しいので動画を追記予定。

# コード
```vb
Option Explicit

' win32api
Private Declare Sub Sleep Lib "kernel32" (ByVal ms As Long)
Private Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)

'仮想キーコード
Const VK_SNAPSHOT = &H2C ' Printscreen
Const VK_MENU = &H12 ' Alt

' ターゲットアプリのタイトルバー文字列
Const APP_TITLE = "フォト"

Dim screenshotCount

' ターゲットアプリのスクリーンショット画像(.png)を取得する.
' 出力ファイル名は選択したセルの文字列を使う
Public Sub GetScreenshotPng()

    Dim objWsh
    Set objWsh = CreateObject("WScript.Shell")

    Dim objFso
    Set objFso = CreateObject("Scripting.FileSystemObject")

    Dim objWord
    Set objWord = CreateObject("Word.Application")

    '****
    ' 0. エラーチェック/初期化
    '****
    ' ターゲットアプリの存在確認
    If Not objWord.Tasks.Exists(APP_TITLE) Then
        MsgBox APP_TITLE & "が見つかりません"
        GoTo ReleaseObjects
    End If
    
    If IsEmpty(screenshotCount) Then
       screenshotCount = 0
       Cells(1, 1).Select
    End If

    '****
    ' 1. ターゲットアプリをアクティブにする
    '****

    ' 最小化されている場合, AppActivateしても画面が出てこない.
    ' WordのTaskオブジェクトでwindowStateを操作して, 標準の状態に戻したあと,
    ' アクティブにする

    If objWord.Tasks(APP_TITLE).WindowState = 2 Then
        objWord.Tasks(APP_TITLE).WindowState = 0
    End If

    objWord.Tasks(APP_TITLE).Activate

    '****
    ' 2. ターゲットアプリのアクティブ待ち
    '****
    ' Windows10のアニメーション効果が有効な場合, AppActivateのあと少しウェイトを入れる必要がある
    Call Sleep(500)


    '****
    ' 3. Alt + PrintScreenを押下する
    '****
    'Alt + PrintScreen
    Call keybd_event(VK_MENU, 0, 1, 0) 'Alt押下
    Call keybd_event(VK_SNAPSHOT, 0, 1, 0) 'PrintScreen押下
    Call keybd_event(VK_SNAPSHOT, 0, 3, 0) 'PrintScreen離し
    Call keybd_event(VK_MENU, 0, 3, 0) 'Alt離し


    '****
    ' 4. クリップボードの画像をpngファイル化する
    '****

    ' get_clipboard_image.exeのパスを作成(.xlsmと同じフォルダにあることを期待)
    Dim cmd
    cmd = """" & objFso.BuildPath(ThisWorkbook.Path, "get_clipboard_image.exe") & """"
    
    
    ' get_clipboard_image.exeの引数(出力ファイル名)を作成(.xlsmと同じフォルダに出力することを期待)
    Dim outputfile
    outputfile = objFso.BuildPath(ThisWorkbook.Path, "screenshot-" & screenshotCount & ".png")

    ' 「get_clipboard_image.exe 出力ファイル名」を実行し、成功したらセルにファイル名を記載する
    Dim ret
    ret = objWsh.Run(cmd & " " & """" & outputfile & """", 0, True)
    If ret = 0 Then
        screenshotCount = screenshotCount + 1
        Cells(screenshotCount, 1).Value = outputfile
        Cells(screenshotCount, 1).Select
    End If

ReleaseObjects:
    objWord.Quit
    Set objWord = Nothing
    Set objFso = Nothing
    Set objWsh = Nothing
End Sub

' ターゲットアプリのスクリーンショット画像(.png)をWordにまとめる
Public Sub PasteScreenShotToWord()
    Dim objWord
    Set objWord = CreateObject("Word.Application")
    objWord.Visible = True
    
    Dim doc
    Set doc = objWord.Documents.Add
    
    doc.PageSetup.TopMargin = 0
    
    Dim sheet
    Set sheet = ThisWorkbook.ActiveSheet
    Cells(sheet.UsedRange.Item(1).Row, 1).Select
    Dim i
    For i = sheet.UsedRange.Item(1).Row To sheet.UsedRange.Rows.Count
        With objWord.Selection
            .InlineShapes.AddPicture Cells(i, 1).Value
            .TypeParagraph
            .InsertCaption Label:="図"
            .TypeText "　"
            If Cells(i, 2) <> "" Then
                .TypeText Cells(i, 2).Value
            End If
            .TypeParagraph
        End With
    Next
    
    Dim pic
    For Each pic In objWord.ActiveDocument.InlineShapes
        With pic
            .LockAspectRatio = msoTrue '縦横比固定
            .Width = objWord.MillimetersToPoints(50)  '幅 50 mm
        End With
    Next
    
    objWord.ActiveDocument.Range(0, 0).Select
    objWord.Selection.TypeParagraph
    
     objWord.ActiveDocument.TablesOfFigures.Add objWord.Selection.Range, "図"
     objWord.ActiveDocument.TablesOfFigures(1).TabLeader = 2 ' wdTabLeaderDots
     objWord.ActiveDocument.TablesOfFigures.Format = 0 ' wdIndexIndent
     
     
ReleaseObjects:
    'objWord.Visible = Falseなら, Quitする
    If objWord.Visible = False Then
        objWord.Quit
    End If
    Set objWord = Nothing
End Sub

```

# 参考

- [【コード】表示倍率を変更するWordマクロ - みんなのワードマクロ][1]
- [【コード】左右の余白を調整するWordマクロ（その２）- みんなのワードマクロ][2]
- [図表番号を挿入する（Seqフィールドの利用）- みんなのワードマクロ][3]
- [ページ設定：サイズ - We-vba][4]
- [文書の先頭にカーソルを移動するWordマクロ ワードマクロ・Word VBAの使い方-Selection][6]
- [空白セルを正しく判定する方法（IsEmpty,IsError,HasFormula）- VBA技術解説][8]
- [TablesOfFigures.Add メソッド (Word) - Microsoft Docs][5]
- [SaveAs2 メソッド (Word) - Microsoft Docs][7]
- [WdIndexType enumeration (Word) - Microsoft Docs][9]
- [WdTabLeader enumeration (Word) - Microsoft Docs][10]
- [Word VBAでFor Each～Next文を使ってフォルダ内のドキュメント全てを操作をする方法][11]

[1]:https://www.wordvbalab.com/code/4529/
[2]:https://www.wordvbalab.com/code/4986/
[3]:https://ameblo.jp/gidgeerock/entry-10771723372.html
[4]:https://we-vba.info/word_vba/page3/
[5]:https://docs.microsoft.com/ja-jp/office/vba/api/word.tablesoffigures.add
[6]:https://www.relief.jp/docs/word-vba-selecting-start-documents.html
[7]:https://docs.microsoft.com/ja-jp/office/vba/api/word.saveas2
[8]:https://excel-ubara.com/excelvba4/EXCEL237.html
[9]:https://docs.microsoft.com/en-us/office/vba/api/word.wdindextype
[10]:https://docs.microsoft.com/en-us/office/vba/api/word.wdtableader
[11]:https://tonari-it.com/word-vba-filesystem-for-each/


<!--
<a href="https://pixabay.com/ja/users/asundermeier-448808/?utm_source=link-attribution&amp;utm_medium=referral&amp;utm_campaign=image&amp;utm_content=4059473">Anke Sundermeier</a>による<a href="https://pixabay.com/?utm_source=link-attribution&amp;utm_medium=referral&amp;utm_campaign=image&amp;utm_content=4059473">Pixabay</a>からの画像
<a href="https://pixabay.com/ja/users/EvgeniT-4930349/?utm_source=link-attribution&amp;utm_medium=referral&amp;utm_campaign=image&amp;utm_content=4055838">Evgeni Tcherkasski</a>による<a href="https://pixabay.com/?utm_source=link-attribution&amp;utm_medium=referral&amp;utm_campaign=image&amp;utm_content=4055838">Pixabay</a>からの画像
<a href="https://pixabay.com/ja/users/adege-4994132/?utm_source=link-attribution&amp;utm_medium=referral&amp;utm_campaign=image&amp;utm_content=2246889">adege</a>による<a href="https://pixabay.com/?utm_source=link-attribution&amp;utm_medium=referral&amp;utm_campaign=image&amp;utm_content=2246889">Pixabay</a>からの画像
<a href="https://pixabay.com/ja/users/Daniel_Nebreda-3841176/?utm_source=link-attribution&amp;utm_medium=referral&amp;utm_campaign=image&amp;utm_content=3118387">Daniel Nebreda</a>による<a href="https://pixabay.com/?utm_source=link-attribution&amp;utm_medium=referral&amp;utm_campaign=image&amp;utm_content=3118387">Pixabay</a>からの画像
<a href="https://pixabay.com/ja/users/EvgeniT-4930349/?utm_source=link-attribution&amp;utm_medium=referral&amp;utm_campaign=image&amp;utm_content=4080561">Evgeni Tcherkasski</a>による<a href="https://pixabay.com/?utm_source=link-attribution&amp;utm_medium=referral&amp;utm_campaign=image&amp;utm_content=4080561">Pixabay</a>からの画像
-->