'http://www.excelpx.com/thread-455204-1-1.html
'入口
Sub ImportPic()
Dim p, f, A, i
Application.ScreenUpdating = False
ActiveSheet.Pictures.Delete
p = ThisWorkbook.Path & "\图片源\"
A = Range("a1").CurrentRegion
For i = 2 To UBound(A)
f = A(i, 2) & ".jpg"
If Dir(p & f) <> "" Then Call RngSize(p & f, Cells(i, 3))
Next i
Call AddV(p) '可选
Call SetOnClick '可选
End Sub
'数据有效性序列
Sub AddV(p)
Dim f, s
f = Dir(p)
Do While f <> ""
s = s & "," & VBA.Replace(f, ".jpg", "")
f = Dir
Loop
If s = "" Then End
ActiveSheet.ClearCircles
With Range("b2:b1000").Validation
.Delete
.Add Type:=xlValidateList, Formula1:=Mid(s, 2)
End With
ActiveSheet.CircleInvalid
End Sub
'按单元格大小(图片路径, 图片单元格)
Sub RngSize(f, rng)
ActiveSheet.Shapes.AddPicture Filename:=f, LinkToFile:=True, SaveWithDocument:=True, _
Left:=rng.Left, Top:=rng.Top, Width:=rng.Width, _
Height:=rng.Offset(0, -1).MergeArea.Height
End Sub
'按图片大小(图片路径, 图片单元格)
Sub PicSize(f, rng)
Dim pixel
With ActiveSheet.Pictures.Insert(f)
.Left = rng.Left
.Top = rng.Top
If .Height <= 409 Then rng.RowHeight = .Height Else MsgBox "图片过高": End
pixel = .Width * 96 / 72
rng.ColumnWidth = IIf(pixel >= 13, (pixel - 5) / 8, pixel / 13)
End With
End Sub
'设置单击指定对象时运行的宏的名称
Private Sub SetOnClick()
Dim x
For Each x In ActiveSheet.Shapes
If x.Type = msoLinkedPicture Then x.OnAction = "onClick"
Next
End Sub
'缩放图片
Private Sub OnClick()
Dim w, h, i
With ActiveSheet.Shapes(Application.Caller)
w = .TopLeftCell.Width
h = .TopLeftCell.Height
i = 5 '放大倍数
If .Width = w Then
.Width = w * i
.Height = h * i
Else
.Width = w
.Height = h
End If
.ZOrder 0 '使形状置于顶层
End With
End Sub