|
|
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件 ★ 免费下载 ★ ★ 使用帮助★
Sub ShapePic()
Dim shpPic As Shape
Dim picW As Single, picH As Single '图片的宽和高
Dim cellW As Single, cellH As Single '单元格的宽和高
Dim cellL As Single, cellT As Single '单元格的左边和上边位置（左上角）
Dim rtoW As Single, rtoH As Single '单元格和图片的宽和高的比例
lj = ThisWorkbook.Path & "\图片库\"
r = Cells(Rows.Count, "C").End(xlUp).Row
For Each shp In ActiveSheet.Shapes
shp.Delete
Next shp
For i = 2 To r
If Cells(i, 3) <> Empty Then
tp = Dir(lj & Cells(i, 3) & ".jpg")
If tp <> "" Then
Cells(i, 2).Select
If ActiveCell.MergeCells Then '判断所选单元格是否是合并单元格
cellW = ActiveCell.MergeArea.Width '是的话，cellW和cellH分别等于合并单元格的宽和高
cellH = ActiveCell.MergeArea.Height
Else
cellW = ActiveCell.Width '不是的话，cellW和cellH分别等于单元格的宽和高
cellH = ActiveCell.Height
End If
cellL = ActiveCell.Left
cellT = ActiveCell.Top
Set shpPic = ActiveSheet.Shapes.AddPicture(lj & tp, msoFalse, msoTrue, cellL, cellT, -1, -1)
picW = shpPic.Width
picH = shpPic.Height
rtoW = cellW / picW * 0.98 '设置单元格和图片的比例。并设置最终比例为原始比例的98%；
rtoH = cellH / picH * 0.98 '这样的目的在于不要让图片充满整个单元格，以便可以让人看到单元格的边线。
shpPic.LockAspectRatio = msoTrue
If rtoW < rtoH Then
shpPic.ScaleHeight rtoW, msoTrue, msoScaleFromTopLeft
Else
shpPic.ScaleHeight rtoH, msoTrue, msoScaleFromTopLeft
End If
picW = shpPic.Width '根据上面确认的比例，为图片的宽和高重新赋值
picH = shpPic.Height
shpPic.IncrementLeft (cellW - picW) / 2 '移动单元格的图片，使图片位于单元格（宽和高）的中间。
shpPic.IncrementTop (cellH - picH) / 2
End If
End If
Set shpPic = Nothing
Next i
End Sub |
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2024-3-22 08:03
楼主