概要

「ExcelでスクリーンショットコレクションするならWordの方がいいよというお話」でコメントした

スクリーンショット画像をとったとき、Excelファイルに「ファイル名、キャプション、図表番号」のリストを作っておく。※キャプションは後から手入力する。

そのリストからWordのCOMオブジェクトを利用して「図の挿入～図表目次を自動で作成」する。

・・・ということはできそうな気もする

の検証コード。

一応できた。

予定

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

コード

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に貼って図表番号を付ける

概要

予定

コード

参考