Wordマクロ：画像のサムネイルシートを生成する(2/3)

http://curo5170.s1008.xrea.com/x/2020/04/16/post-26/

前回の記事で触れたサムネイルシートを生成するWordマクロの補足です。

１．マクロの解説

①メイン処理

ボタンを押して呼び出されるコードは次の通りです。
次の処理はサブルーチンにして別にしてます。
・DelPictTalbe ‘ 既存の写真表の削除
・NewPictTable(oPictTable as Table) ‘写真用の空の表を作成
・AllPictPasetTable _ ‘指定したフォルダの写真を指定した表に貼り付け
(strDirPath as string, oPictTalbe as Talbe)
・RenameSave ‘保存処理

Option Explicit

'貼り付ける写真のサイズ(ピクセル)
'縦横のどちらかがこのサイズになるよう拡大縮小する
Const LL_PicWidth As Long = 220
Const LL_PicHeight As Long = 200

'************************************************
'メインの処理。
'************************************************
Public Sub 画像一覧生成()

    Application.ScreenUpdating = False
    
    Call DelPictTable               '既存の写真表を削除

    Dim oPictTable As Table
    Call NewPictTable(oPictTable)   '新しい写真表を作成

    Call AllPictPasetTable(ActiveDocument.Path, oPictTable)
                                    '写真写真表に貼りつけ
    Application.ScreenUpdating = True
    
    Call RenameSave                 '保存処理
    
    
End Sub

なお、張り付ける画像のサイズは動的に判断するように作ると格好いいと思うのですが、面倒くさいので
Const LL_PicWidth As Long = 220
Const LL_PicHeight As Long = 200
と定数宣言しています。この値はA4の1ページに8枚くらい写真が入るよう、適当にトライアンドエラーで求めた値ですので、用紙サイズや余白を変更した場合には適宜変更する必要があります。

また、Application.ScreenUpdatingのFalse/Trueは、画面の更新の無効/有効です。表を操作する際、本来は.Range()で操作先を指定するのがスマートな書き方だと思いますが、今回のマクロはSelection　つまりカーソル移動させて処理しています。
格好悪いのですが、表に行を追加する処理がスマートに掛けるので、こっちを選んでしまいました・・・具体的にはSelection.MoveRight Unit:=wdCellで次のセルに移動＆一番右端のセルだった場合は行を追加して左端へ、をやってくれる。・・・。
このとき、画面が激しく動いて処理が遅くなるので、表の処理をしている最中は画面の更新を切ってます。

Syntax
expression.ScreenUpdating
expression An expression that returns an Application object.

②表の削除と作製

表消すDelPictTableと、表を作るNewPictTalbeは次の通り。
表に張り付けたのは
・レイアウトがきれいになる
・サムネイルを一括で消すとき、一発で消せる(表を消したら道連れ）
・コピペするとき、表ごと持っていける
です。
上等なマクロなら、既存の写真に追加したり差分を張り付けたりできるべきでしょうが、そういう面倒なのは今回ナシです。

'************************************************
'既存の表が邪魔になるので削除。
'************************************************
'表のタイトル要素が"写真表"になっているかで、消す表を判断。
Private Sub DelPictTable()
    Dim oTable As Table
    Dim bFirstCase As Boolean
    For Each oTable In ActiveDocument.Tables    'ドキュメント中の表を総当たりする
'        If oTable.Title = "写真表" Then         'タイトルが"写真表"か比較する
'2007ではtitleプロパティがない？
            If bFirstCase = False Then
                '表が見つかった場合、念のため消していいか聞く。一度okしたら複数あった場合もいちいち聞かない。
                Dim bDelete As Integer
                bDelete = MsgBox("既存の写真表を削除します", vbOKCancel)
                If bDelete = vbCancel Then
                    Exit Sub
                End If
                bFirstCase = True
            End If
            oTable.Delete
'        End If
    Next
End Sub

'************************************************
'写真用の表を生成
'************************************************
Private Sub NewPictTable(oPictTable As Table)
    'ボタンが後ろに行くと面倒なので、カーソルを文書の一番最後に移動させる。
    Selection.EndKey Unit:=wdStory
    
    Set oPictTable = ActiveDocument.Tables.Add( _
        Range:=Selection.Range, _
        NumRows:=1, _
        NumColumns:= _
        2, _
        DefaultTableBehavior:=wdWord9TableBehavior, _
        AutoFitBehavior:= _
        wdAutoFitFixed)
'    With Selection.Tables(1)
    With oPictTable
        If .Style <> "表 (格子)" Then
            .Style = "表 (格子)"
        End If
        .Borders.InsideLineStyle = wdLineStyleNone
        .Borders.OutsideLineStyle = wdLineStyleNone
        .ApplyStyleHeadingRows = True
        .ApplyStyleLastRow = False
        .ApplyStyleFirstColumn = True
        .ApplyStyleLastColumn = False
        .ApplyStyleRowBands = True
        .ApplyStyleColumnBands = False
'        .Title = "写真表"
    End With
    oPictTable.Rows(1).AllowBreakAcrossPages = False
End Sub

表を消したり作ったりするマクロは、その辺から拾ってきたものを組み合わせました。

インストラクターのネタ帳
https://www.relief.jp/docs/word-vba-add-a-table.html

Microsoft docs
https://docs.microsoft.com/ja-jp/office/vba/word/concepts/working-with-word/working-with-tables

個人的な味付けとしては、将来このマクロを何か別の書式に流用する際、見境いなく表を削除する処理は、まずかろうと思って工夫したところです。
マクロで自動挿入した表なのか、ユーザーが作成した表なのか見分ける簡単な手法として、.Titleプロパティを使用しています。マクロで表を作成する際、.TItleプロパティに”写真表”をセットしており、削除するときに”写真表”なのかで消すべきか判断しています。
・・ところが、Word2007では.Titleプロパティが使えないのです…したがって今は.Titleを使わないようになっています。もしWord2010以降でしか使わないのであれば、.Titleを使用したほうが良いと思います。

---

③写真の貼り付け

写真を貼り付ける処理は、フォルダ内のファイルを総当たりする親のサブルーチンと、ファイルの種類判定と1枚の貼り付け処理の２つの子のサブルーチンに分けました。
図の貼り付けは意外と簡単で、Selection.InlineShapes.Addpictureで簡単に貼り付けることができます。コツとしてはサイズを変えたりする際、Shapeが行方不明になってしまわないよう、oShape as InlineShapesにAddpictureで帰ってくるオブジェクトを覚えておくことでしょうか。

'************************************************
'特定フォルダの写真を選択した表に一括貼り付け
'************************************************
Private Sub AllPictPasetTable(strDirPath As String, oDistTable As Table)
    Dim objFso As New Scripting.FileSystemObject
    Dim objFile As File
    Dim strFolderName As String
    Dim lTotalSize As Long
    Dim strFileName As String
    
    oDistTable.Cell(1, 1).Select
    
    For Each objFile In objFso.GetFolder(strDirPath).Files
        strFileName = objFile.Name
        If ChkThisPict(strFileName) Then
            Selection.Range.Paragraphs.Alignment = wdAlignParagraphCenter
    
            '写真を貼り付ける
            Call SetPict(objFile)
            lTotalSize = lTotalSize + objFile.Size
            Selection.MoveRight Unit:=wdCell
            
            strFolderName = objFile.ParentFolder.Name
        End If
    Next

    Selection.Range.Paragraphs.Alignment = wdAlignParagraphLeft
    Selection.TypeText "貼り付けた画像の合計サイズは " & Format(lTotalSize / 1024 / 1024, "0.00") & " MBでした。" & vbCrLf & "元画像フォルダは" & strDirPath & "でした。"

End Sub


'************************************************
'ファイル名的に写真か判定する。
'************************************************
Private Function ChkThisPict(strFileName As String) As Boolean
    Dim objFso As New Scripting.FileSystemObject

    Dim strExtension As String
    strExtension = objFso.GetExtensionName(strFileName)
    strExtension = LCase(strExtension)
    Select Case strExtension
        Case "jpg", "jpeg", "bmp", "png", "tif", "tiff"
            ChkThisPict = True
        Case Else
            ChkThisPict = False
    End Select

End Function

'************************************************
'選択位置に写真を張り付け
'************************************************
Private Sub SetPict(objFile As File)
    '選択位置に画像を張り付け。後でサイズ調整するのでオブジェクトを取っておく。
    Dim oShape As InlineShape
    Set oShape = Selection.InlineShapes.AddPicture( _
        FileName:=objFile.Path, _
        linktofile:=False, _
        savewithdocument:=True)

    '縦横それぞれサイズから縮尺を計算
    Dim fRatioWidth As Single
    Dim fRatioHeight As Single
    fRatioWidth = LL_PicWidth / oShape.Width
    fRatioHeight = LL_PicHeight / oShape.Height
    
    '小さいほうの縮尺を採用する。(はみ出さないように。）
    Dim fRatio
    If fRatioWidth < fRatioHeight Then
        fRatio = fRatioWidth
    Else
        fRatio = fRatioHeight
    End If
    oShape.Width = oShape.Width * fRatio
    oShape.Height = oShape.Height * fRatio
    
    oShape.Range.InsertAfter (objFile.Name & "(" & Format(objFile.Size / 1024 / 1024, "0.00") & "MB)")

End Sub

---

本当はもっと何か解説的なこと、作る際に調べたりして手間取ったことをメモしておこうと思ったのですが・・・作って時間がたつと忘れてしまいますね。うーん。