Shapes.AddPicture不调整行高

Question

尝试运行宏以提示选择图像，然后将其放置到工作簿中，它将图片的大小调整为目标列的宽度（我想要的），但不会调整行高以匹配图像的高度

我尝试过切换功能等，但是row.height似乎没有任何作用

    Sub uploadpic()
    Dim r As Range, Shrink As Long
    Dim shpPic As Shape
    Dim shpPic2 As Shape
    Dim myfile As String
    Dim myfile2 As String
    Application.ScreenUpdating = True
    Shrink = 0

            'got some code running here in between that isn't causing an issue



    On Error Resume Next


    For Each r In Range("K2:K" & Cells(Rows.Count, 1).End(xlUp).Row)


If r.Value = "" Then
myfile = Application.GetOpenFilename(FileFilter:="Pictures, *.jpg; *.gif; *.png", Title:="Select an Issue Picture", MultiSelect:=False)
    ThisWorkbook.Sheets("DATA").Range("K2").Value = myfile
    Set shpPic = ActiveSheet.Shapes.AddPicture(Filename:=myfile, linktofile:=msoFalse, _
        savewithdocument:=msoTrue, Left:=Cells(r.Row, 12).Left + Shrink, Top:=Cells(r.Row, 12).Top + Shrink, _
            Width:=-1, Height:=-1)
    With shpPic
        .LockAspectRatio = msoTrue
        .Width = Columns(12).Width - (2 * Shrink)
        Rows("2:2").RowHeight = .Height + (2 * Shrink)

              End With
        'corrective action pic
        myfile2 = Application.GetOpenFilename(FileFilter:="Pictures, *.jpg; *.gif; *.png", Title:="Select an Corrective Picture", MultiSelect:=False)
            ThisWorkbook.Sheets("DATA").Range("M2").Value = myfile2
            Set shpPic2 = ActiveSheet.Shapes.AddPicture(Filename:=myfile2, linktofile:=msoFalse, _
        savewithdocument:=msoTrue, Left:=Cells(r.Row, 14).Left + Shrink, Top:=Cells(r.Row, 14).Top + Shrink, _
            Width:=-1, Height:=-1)
    With shpPic2
        .LockAspectRatio = msoTrue
        .Width = Columns(14).Width - (2 * Shrink)
         Rows("2:2").RowHeight = .Height + (2 * Shrink)


End With
End If
    Next r

    Application.ScreenUpdating = True


    End Sub

我希望出现提示，以添加2张照片“问题图片”和“校正图片”，然后将其放置在第12和14列中，其中照片会调整大小以适合列宽，但行高度会进行调整以匹配图片高度。