Excelに写真をアスペクト比4:3でトリミングして貼り付ける

別記事でも触れていますが、私は仕事上Excelに写真を貼り付ける作業が多々あります。神エクセル撲滅協会理事（自称）としては誠に不本意ですが、強大な勢力を誇るExcel至上主義のもとで生きていく以上やむを得ません。

せめてもの抵抗として、セルを選択したらファイル選択ダイアログから写真を選ぶだけで、セルサイズに合わせて貼り付けが完了するように写真取り込みマクロを組んで省力化しているのですが、最近このマクロにある問題が発生しました。

それは、長らく写真撮影機材として活躍していたデジカメが完全なるオワコンとなり、みんなスマホで撮影するのでアス比16:9の写真ばかりになっていることです。一方で写真を貼り付ける台帳は4:3の枠でセルも4:3でぴったりはまるように調整してあります。

よって4:3アス比のセルに16:9の写真をマクロで貼ると、余白が空きまくるわサイズが小さくなるわで、そのまま使うわけにはいかないので、Excel上で4:3にトリミングしたり、あらかじめ写真ファイルをトリミング処理したりといった作業が必要になります。今回はこのトリミング作業を写真取り込みマクロに統合し取り込み時にすべてやってしまいます。

16:9の写真を4:3にトリミングしてシートへ貼り付けるマクロ

さっそくですが、ソースコードです。Excelファイルの構成は別記事↓で使用したものを流用します。

写真台帳シートは次のようなもので、「写真」セルをダブルクリックでファイル選択ダイアログが開きます。

ワークシートのダブルクリックイベントでメインのプロシージャをコールします。「写真」セルだけに反応するように条件を付けておきます。

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    If Target.Column = 2 Then
        If Target(1, 1).Value = "写真" Then
            Call insertTrimImage(Target)
            Cancel = True
        End If
    End If
End Sub

メインのプロシージャです。

Sub insertTrimImage(Target As Range)
    Const WH_RATIO As Double = 4 / 3

    Dim fp As String
    fp = Application.GetOpenFilename("写真,*.jpg")
    
    If Not fp = "False" Then
        Dim img As Shape
        Set img = Target.Parent.Shapes.AddPicture(Filename:=fp, _
                LinkToFile:=False, SaveWithDocument:=True, _
                Left:=Target.Left, Top:=Target.Top, Width:=-1, Height:=-1)
           
        If img.Width / img.Height > WH_RATIO Then
            Dim cropPixel As Long
            cropPixel = Int((img.Width - img.Height * WH_RATIO) / 2)
            
            With img.PictureFormat
                .CropLeft = cropPixel 
                .CropRight = cropPixel 
            End With
        End If
            
        With img
            .Width = Target.Width
            .Height = Target.Width / WH_RATIO
            .Left = Target.Left
            .Top = Target.Top
        End With
        
        Dim fs As Object
        Set fs = CreateObject("Scripting.FileSystemObject")
        Dim dlm As Date
        dlm = fs.GetFile(fp).DateLastModified
        Target.Parent.Cells(Target.Row + 5, Target.Column - 1).Value = dlm
    End If
End Sub

うごかしてみる

次のような写真を撮影しました。

アス比16:9で、トリミングがわかりやすいようにわざと目いっぱい菌類を配置しました。

台帳シートの「写真」セルをダブルクリックでファイル選択ダイアログが出るので、写真を選択します。

16:9の両端がカットされアス比4:3になりセルにあわせて挿入されます。撮影日時には写真ファイルの更新日時が入るようにしています。

Excel上でのトリミングのため、実際には16:9のまま挿入され、表示上4:3になっています。再度メニューからトリミングを選択するとそれがわかります。

なので、このマクロで楽をするためには撮影者が被写体を真ん中へ捉える必要があるということです。あとはスマホのクソデカサイズのまま取り込み保存するとファイルサイズがとんでもないことになるので、画像圧縮などの処理をかませたほうがいいですね。

解説

特に変わったことをしているわけではなく、ありふれたコードの組み合わせですが、簡単に。

シートのダブルクリックイベントからわたってきた、写真挿入先となるRnageオブジェクトをTargetとして、こいつを起点にします。

TargetのParentプロパティで、そのRangeが属するシートを取得できるのでシートのShapes.AddPictureメソッドで写真ファイルをShapeオブジェクトとして挿入します。

AddPictureは引数を7つとり、しかも全部必須というPython使いからしたら冗談だろと思うような仕様ですが、どうしようもないので全部指定します。

Dim img As Shape
Set img = Target.Parent.Shapes.AddPicture(Filename:=fp, _
          LinkToFile:=False, SaveWithDocument:=True, _
          Left:=Target.Left, Top:=Target.Top, Width:=-1, Height:=-1)

引数のうちWidthとHeightはその名の通りリターンとなるShapeオブジェクトの縦、横サイズを指定するのですが、-1をわたすことで元の画像ファイルのそれをあらわすことができます。サイズはあとから変更するため-1をわたしておきます。

その他の引数の意味は公式リファレンスをご確認ください。通常の用途であればこのコードで何の問題もないかと思います。

AddPictureのリターンはimg変数に格納されます。

定数WH_RATIOはアスペクト比で今回は4:3にしたいので、4/3を設定しています。これとimgのアスペクト比を比較してWH_RATIOより大きければ、すなわち4:3より大きければトリミング処理を実行します。

トリミング処理はPictureFormatオブジェクトのCrop～プロパティを使います。今回は縦サイズを基準にして横を左右等幅にトリミングします。

img.HeightにWH_RATIOを乗じた値がimgを4:3にしたときの横幅になるので、それを現在のimg.Widthから引いて半分にするとトリミングすべき左右幅がわかります。これを小数点以下を除いてcropPixel変数に入れてCropLeftとCropRightに設定すると4:3トリミングが完了します。

If img.Width / img.Height > WH_RATIO Then
    Dim cropPixel As Long
    cropPixel = Int((img.Width - img.Height * WH_RATIO) / 2)
            
    With img.PictureFormat
        .CropLeft = cropPixel 
        .CropRight = cropPixel 
    End With
End If

このままではまだ元の画像サイズなので、だいたいはセルより大きい状態です。Target.Widthに合わせてimgのサイズを変更していきます。

img.HeightはWidthをセル幅に合わせたので、アス比を保持するにはWidthにWH_RATIOの逆数を乗じて求めた値を設定します。Left、TopはTargetと同じにします。

最後にFileSystemObjectを使ってファイル更新日時を取得して所定のセルへ代入します。