插入图片
Sub add_pic1()
c_add1 = fc("pic_series")
fpath1 = ThisWorkbook.Path & "\img"
'---
On Error Resume Next
Dim tmpRge As Range '定义单元格
Set SH = Sheets("Sheet1")
SH.Select
' For Each SP In SH.Shapes '删除表中原来所有的图片
' SP.Delete
' Next
Set FSO = CreateObject("Scripting.FileSystemObject")
ARRGS = Split("BMP,RLE,PNG,JPG,", ",") '多种格式
For i = 2 To SH.Range("A65536").End(xlUp).Row
' If SH.Cells(i, 1) = "" Then Exit For
SH.Range(convert1(c_add1) & i).Select
For X = 0 To UBound(ARRGS)
STR1 = fpath1 & "" & Trim(SH.Cells(c_add1, 1)) & "." & ARRGS(X)
If FSO.FileExists(STR1) = True Then
SH.Pictures.Insert(STR1).Select
With Selection
.Placement = xlMoveAndSize
.ShapeRange.LockAspectRatio = msoFalse
.Top = ActiveCell.Top + 1
.Left = ActiveCell.Left + 1
.Height = ActiveCell.Height + 1 '设置为“+1”,达到随单元格变化。若完全在单元格内部,那么其不会跟着单元格变化
.Width = ActiveCell.Width + 1
End With
Exit For
End If
Next X
Next i
http://club.excelhome.net/forum.php?mod=redirect&goto=findpost&ptid=1176048&pid=8018229
Sub zf()
On Error Resume Next
Application.ScreenUpdating = False
ActiveSheet.DrawingObjects.Delete
Dim i%
Dim MR As Range
For Each MR In Range("C2:h" & 5)
If Not IsEmpty(MR) And MR <> "无" Then
MR.Select
ML = MR.Left + 4
MT = MR.Top + 4
MW = MR.Width * 0.9
MH = MR.Height * 0.9
ActiveSheet.Shapes.AddShape(msoShapeRectangle, ML, MT, MW, MH).Select
Selection.ShapeRange.Fill.UserPicture _
ActiveWorkbook.Path & "\图片\" & MR.Value & ".jpg" '当前文件所在目录下以当前单元内容为名称的.jpg图片
End If
Next
Application.ScreenUpdating = True
End Sub