【VBA】外部の画像を読込んで、リンクを作成する

#はじめに#
備忘録として投稿します。
Excelに画像を読込んで、読込んだ画像にリンクを設定するマクロです。
画像をクリックすると、元の画像が表示されるようにします。

このマクロを書いたのは、入力された情報をもとにレポートを作成し、固定の枠に（セルが結合されていてもOK）画像を差し込むときに作りました。

#調整が必要だったこと#
わりと簡単に出来るのですが、細かい部分で調整が必要でした。
・画像を差し込む枠から、画像が少しはみ出る。（枠の内側に収まるようにtop,leftの位置を「+1」して調整）
・画像を枠のサイズに合わせると、画像がゆがむ。（画像の縦横比率を維持したまま、縮小する。）
・画像を縮小すると、少しはみ出る。（1％だけ小さくする。）

#コード#
コードの細かい説明は、コメントに書きました。

Private Sub PictureLinkAdd(ByVal strSheetName As String, ByVal strRange As String, ByVal strPicturePath As String)
'*************************************
'画像リンクを作成します。
'*************************************
'＜注意＞
’シートの表示を「標準」にしておかないと画像がずれて配置される事がありました。

    On Error GoTo PictureLinkAddErr
    
    'オブジェクトをセット
    Dim objSheet As Worksheet
    Set objSheet = ThisWorkbook.Sheets(strSheetName)
    
    '画像の取り込み
    'top,leftの位置を枠の内側に収まるように「+1」して調整する。
    With objSheet.Shapes.AddPicture( _
            FileName:=strPicturePath, _
            LinkToFile:=False, _
            SaveWithDocument:=True, _
            Left:=objSheet.Range(strRange).Left + 1, _
            Top:=objSheet.Range(strRange).Top + 1, _
            Width:=0, _
            Height:=0)
        '一旦、元のサイズに戻す
        .ScaleHeight 1, msoTrue
        .ScaleWidth 1, msoTrue
        'サイズ調整、枠内に収める(アスペクト比を変えずに画像のサイズ調整)
        Dim objRange As Range
        Set objRange = objSheet.Range(strRange)
        Dim dblScal As Double
        If objRange.Width / .Width < objRange.Height / .Height Then
            dblScal = WorksheetFunction.RoundDown(objRange.Width / .Width, 2)
        Else
            dblScal = WorksheetFunction.RoundDown(objRange.Height / .Height, 2)
        End If
        Set objRange = Nothing
        '画像がはみ出さないように「１％」だけ小さくする
        dblScal = dblScal - 0.01
        .Width = .Width * dblScal
        .Height = .Height * dblScal
    End With
    '画像にハイパーリンクを作成する（画像をクリックすると画像を開くようになる）
    'objSheet.Shapes.Countは、最後に追加されたオブジェクト（＝自分で追加した画像オブジェクト）のインデックスを得るために使っています。
    objSheet.Hyperlinks.Add Anchor:=objSheet.Shapes(objSheet.Shapes.Count), Address:=strPicturePath
    
    Exit Sub

PictureLinkAddErr:
'ここで起きたエラーはスルーする。
'調査の時は、on error gotoをコメントにして下さい。
    Err.Number = 0
    Set objSheet = Nothing
End Sub

#最後に#
最初は難しく思いましたが、案外簡単に出来ます。
※シートの表示を「標準」にしておかないと画像がずれてしまう事があるので、注意してください。