Excelでダブルクリックしたセルに画像を張り付ける方法

    Cancel = True

    '画像挿入
    Call PasteImage(Target)
End If

Dim fileNm As String
Dim shp As Object
Dim rng As Range
Dim myRange As Range
Dim pWidth As Single
Dim pHeight As Single
Dim pLeft As Single
Dim pTop As Single
Dim mWidth As Integer
Dim mHeight As Integer
Dim rX As Single
Dim rY As Single
Dim objShape As Shape

'画像選択
fileNm = Application.GetOpenFilename _
       ("jpg bmp tif png gif,*.jpg;*.bmp;*.tif;*.png;*.gif", , "画像の選択", , False)
If fileNm = "False" Then
    MsgBox "画像を選択してください"
    Exit Sub
End If

'セル内の画像削除
For Each shp In ActiveSheet.Pictures
    Set rng = Range(shp.TopLeftCell, shp.BottomRightCell)

    If Not (Intersect(rng, Selection) Is Nothing) Then
        shp.Delete
    End If
Next

mWidth = 3  '左右余白
mHeight = 3 '上下余白
Set myRange = Target
Application.ScreenUpdating = False

'表示位置の取得
With ActiveSheet.Pictures.Insert(fileNm).ShapeRange
    '左上隅の位置取得
    pLeft = .Left
    pTop = .Top
    '一旦画像を削除する
    .Delete
End With

'画像サイズの取得
Set objShape = ActiveSheet.Shapes.AddPicture( _
    Filename:=fileNm, _
    LinkToFile:=False, _
    SaveWithDocument:=True, _
    Left:=0, _
    Top:=0, _
    Width:=0, _
    Height:=0)

With objShape
    .LockAspectRatio = msoTrue
    .ScaleHeight 1, msoTrue
    .ScaleWidth 1, msoTrue

    '画像サイズをセルの幅、高さに合わせる
    rX = myRange.Width / .Width
    rY = myRange.Height / .Height

    If rX > rY Then
        .Height = .Height * rY - mHeight
        .Width = .Width - mWidth
    Else
        .Height = .Height - mHeight
        .Width = .Width * rX - mWidth
    End If
    pWidth = .Width
    pHeight = .Height

    '表示位置をセルの幅、高さに合わせる
    pLeft = pLeft + (myRange.Width - .Width) / 2
    pTop = pTop + (myRange.Height - .Height) / 2
    '一旦画像を削除する
    .Delete
 End With

'画像の貼り付け
Set objShape = ActiveSheet.Shapes.AddPicture( _
    Filename:=fileNm, _
    LinkToFile:=False, _
    SaveWithDocument:=True, _
    Left:=pLeft, _
    Top:=pTop, _
    Width:=pWidth, _
    Height:=pHeight)

Application.ScreenUpdating = True