【VBA】ダイアログから画像を取得するサンプルコード（実用編）

Sub 画像取得_実用版_SA()

    '＝＝＝＝＝基本設定＝＝＝＝＝
    '取得シートの指定
    Sheet1.Activate '★
    
    '画像取得位置の指定
    Dim GetRng As Range
    Set GetRng = Range("B5") '★
    
    '取得画像のサイズ指定(高さのピクセルサイズで指定)
    Dim PictHeight As Long
    PictHeight = 100 '★

    '＝＝＝＝＝取得画像の選択＝＝＝＝＝
    '画像取得ダイアログを開く
    Dim PictName As String
    PictName = Application.GetOpenFilename _
    ("画像(*.png; *.jpg; *.jpeg; *.gif),*.png; *.jpg; *.jpeg; *.gif", , "画像ファイルの選択")
    
    'ダイアログでキャンセルした場合
    If PictName = "False" Then Exit Sub
    
    '＝＝＝＝＝画像の取得＝＝＝＝＝
    On Error GoTo NextE 'エラー発生時の処理先
    With ActiveSheet
        '指定位置に原本サイズで取得(リンクなし)
        Set GetPic = .Shapes.AddPicture( _
            Filename:=PictName, _
            LinkToFile:=False, _
            SaveWithDocument:=True, _
            Left:=GetRng.Left, _
            Top:=GetRng.Top, _
            Width:=-1, _
            Height:=-1)
    End With

    '＝＝＝＝＝サイズ調整等＝＝＝＝＝
    With GetPic
        '縦横比固定で高さを基準にサイズを指定
        .LockAspectRatio = msoTrue
        .Height = PictHeight
        
        '最前面に配置
        .ZOrder msoBringToFront '最背面に配置する場合はmsoSendToBack
        
        '画像のロック解除(保護シートでも操作できるようにするため)
        .Locked = False
    End With
    
    '＝＝＝＝＝配置調整＝＝＝＝＝
    '取得位置から対象画像を特定
    Dim PictSP As Shape
    For Each PictSP In ActiveSheet.Shapes
        If Not Intersect(Range(PictSP.TopLeftCell, PictSP.BottomRightCell), GetRng) Is Nothing Then
            '画像をセルの中央位置へ移動
            ActiveSheet.Shapes(PictSP.Name).Left = GetRng.Left + (GetRng.Width - ActiveSheet.Shapes(PictSP.Name).Width) / 2
            ActiveSheet.Shapes(PictSP.Name).Top = GetRng.Top + (GetRng.Height - ActiveSheet.Shapes(PictSP.Name).Height) / 2
        End If
    Next
    
    '＝＝＝＝＝終了処理＝＝＝＝＝
    '正常終了
    Exit Sub
    
NextE: 'エラー発生時終了処理
    
    'エラー発生時はメッセージを表示して収量
    MsgBox "取得中にエラーが発生しました。", vbExclamation

End Sub

Sub 画像取得_実用版_PI11()

    '＝＝＝＝＝基本設定＝＝＝＝＝
    '取得シートの指定
    Sheet1.Activate '★
    
    '画像取得位置の指定
    Dim GetRng As Range
    Set GetRng = Range("B5") '★
    
    '取得画像のサイズ指定(高さのピクセルサイズで指定)
    Dim PictHeight As Long
    PictHeight = 100 '★

    '＝＝＝＝＝取得画像の選択＝＝＝＝＝
    '画像取得ダイアログを開く
    Dim PictName As String
    PictName = Application.GetOpenFilename _
    ("画像(*.png; *.jpg; *.jpeg; *.gif),*.png; *.jpg; *.jpeg; *.gif", , "画像ファイルの選択")

    'ダイアログでキャンセルした場合
    If PictName = "False" Then Exit Sub
   
    '＝＝＝＝＝画像の取得＝＝＝＝＝
    On Error GoTo NextE 'エラー発生時の処理先
    With ActiveSheet.Pictures.Insert(PictName)
        .Top = GetRng.Top
        .Left = GetRng.Left
        .CopyPicture    'クリップボードにコピー(リンク切れなしの画像とするためのコピー)
        .Delete         'リンク画像を削除
    End With
    
    '上記でコピーした画像を貼り付け(これでリンク切れなしの画像になる)
    GetRng.Select '貼り付ける場所を指定
    ActiveSheet.Paste
    
    '＝＝＝＝＝サイズ調整＝＝＝＝＝
    '縦横比を固定
    Selection.ShapeRange.LockAspectRatio = msoTrue
    
    'サイズ調整
    Selection.ShapeRange.Height = PictHeight
    
    '＝＝＝＝＝ロック解除と配置調整＝＝＝＝＝
    '取得位置から対象画像を特定
    Dim PictSP As Shape
    For Each PictSP In ActiveSheet.Shapes
        If Not Intersect(Range(PictSP.TopLeftCell, PictSP.BottomRightCell), GetRng) Is Nothing Then
            '画像のロック解除(保護シートでも操作できるようにするため)
            PictSP.Locked = False

            '画像をセルの中央位置へ移動
            ActiveSheet.Shapes(PictSP.Name).Left = GetRng.Left + (GetRng.Width - ActiveSheet.Shapes(PictSP.Name).Width) / 2
            ActiveSheet.Shapes(PictSP.Name).Top = GetRng.Top + (GetRng.Height - ActiveSheet.Shapes(PictSP.Name).Height) / 2
        End If
    Next
    
    '＝＝＝＝＝終了処理＝＝＝＝＝
    '正常終了
    Exit Sub
    
NextE: 'エラー発生時終了処理
    
    'エラー発生時はメッセージを表示して収量
    MsgBox "取得中にエラーが発生しました。", vbExclamation
    Exit Sub

End Sub