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
|