Excel VBA 插入指定图片到单元格并只适应大小

Sub 插入图片()

Dim filenames As String

Dim filefilter1 As String

filefilter1 = ("所有图片文件（*.jpg;*.bmp;*.png;*.gif）,*.jpg;*.bmp;*.png;*.gif")    '所有图片文件后面的括号为中文括号

filenames = Application.GetOpenFilename(filefilter1, , "请选择一个图片文件", , MultiSelect:=False)

'没有选中文件时，做容错处理

If filenames = "False" Then

Exit Sub

End If

'插入图片到指定的单元格

Sheet1.Pictures.Insert(filenames).Select

'图片自适应单元格大小

On Error Resume Next

Dim picW As Single, picH As Single

Dim cellW As Single, cellH As Single

Dim rtoW As Single, rtoH As Single

cellW = ActiveCell.Width

cellH = ActiveCell.Height

picW = Selection.ShapeRange.Width

picH = Selection.ShapeRange.Height

rtoW = cellW / picW * 0.95

rtoH = cellH / picH * 0.95

If rtoW < rtoH Then

    Selection.ShapeRange.ScaleWidth rtoW, msoFalse, msoScaleFromTopLeft

Else

    Selection.ShapeRange.ScaleHeight rtoH, msoFalse, msoScaleFromTopLeft

End If

picW = Selection.ShapeRange.Width

picH = Selection.ShapeRange.Height

Selection.ShapeRange.IncrementLeft (cellW - picW) / 2

Selection.ShapeRange.IncrementTop (cellH - picH) / 2

End Sub