VBAノック29本目：画像の挿入 - 和風スパゲティのレシピ

Excel&VBA解説サイト「エクセルの神髄」様出題の問題集、
「VBA100本ノック」に対する私の回答と解説のページです。

100本ノックの出題リストはこちらから
excel-ubara.com

出題：画像の挿入
ソースコード
解説

出題：画像の挿入

#VBA100本ノック 29本目
ファイル選択ダイアログで画像ファイルを指定し、その画像をアクティブセルにリンクしない図として貼り付けてください。
貼り付けた画像は、縦横比を維持したままセル内に収めてください。
セル内の位置はなるべく真ん中に。
※選択できる拡張子は適当に。

画像挿入サンプル

◇ 出題ページはこちら

ソースコード

Option Explicit

' 100本ノック029：画像の挿入
Sub ダイアログで指定した画像をアクティブセルに挿入する()
    
    Dim 貼付先セル As Range
    Set 貼付先セル = ActiveCell
    
    ' ダイアログボックスで画像ファイルを選択
    Dim path選択画像ファイル As Variant
    path選択画像ファイル = Application.GetOpenFilename(FileFilter:="画像ファイル,*.png;*.bmp;*.jpg;*.gif")
    If path選択画像ファイル = False Then Exit Sub
        
    ' アクティブセルに画像を挿入
    Dim 挿入画像 As Shape
    Set 挿入画像 = ActiveSheet.Shapes.AddPicture( _
        Filename:=path選択画像ファイル, _
        LinkToFile:=False, _
        SaveWithDocument:=True, _
        Left:=貼付先セル.Left, _
        Top:=貼付先セル.Top, _
        Width:=10, _
        Height:=10) ' 省略できないので適当な位置・サイズに
    
    ' サイズを元画像に戻す
    挿入画像.Placement = xlMoveAndSize
    挿入画像.ScaleHeight 1, msoTrue
    挿入画像.ScaleWidth 1, msoTrue
    
    ' 縦横比を固定してまず幅を対象セルと同じ幅に
    挿入画像.LockAspectRatio = msoTrue
    挿入画像.Width = 貼付先セル.Width
    
    ' 高さがオーバーしていたら縮小
    If 挿入画像.Height > 貼付先セル.Height Then
        挿入画像.Height = 貼付先セル.Height - 1
    End If
    
    ' 垂直・水平ともに中央に位置調整
    Dim height差 As Double: height差 = 貼付先セル.Height - 挿入画像.Height
    挿入画像.Top = 貼付先セル.Top + height差 / 2
    Dim width差 As Double: width差 = 貼付先セル.Width - 挿入画像.Width
    挿入画像.Left = 貼付先セル.Left + width差 / 2

End Sub