Public Sub Q()
Application.ScreenUpdating = False
Dim PicName$, pand&, k&, PicPath, i, p, n, PicArr, TitleRow
Dim PicNameCol, PicPath2, PicPath3, TPnameCol, TPCol%, m%
Dim mypath$, myname$
mypath = ThisWorkbook.Path & "\"
myname = Dir(mypath & "*.jpg")
i = 2
PicCol = 1 '图片名称列
TPCol = 2 '图片列
'PicPath2 = ThisWorkbook.Path & "\"
'PicArr = Array(".jpg", ".jpeg", ".bmp", ".png", ".gif") '图片格式
Do While myname <> ""
If myname <> ThisWorkbook.Name Then
'ActiveSheet.Shapes.AddPicture mypath & myname, True, True, _
Cells(i, TPCol).Left, Cells(i, TPCol).Top, _
Cells(i, TPCol).Width, Cells(i, TPCol).Height
Set shp = Sheet1.Shapes.AddPicture(mypath & myname, msoFalse, msoCTrue, 0, 0, -1, -1)
With shp
'裁剪
.PictureFormat.CropTop = 30 '下移裁剪，裁剪上边
.PictureFormat.CropLeft = 30 '右移裁剪，裁剪左边
.PictureFormat.CropBottom = 30 '上移裁剪，裁剪下边
.PictureFormat.CropRight = 30 '左移裁剪，裁剪右边
'裁剪
'移动旋转
'通常移动距离都是和裁剪相对应的，这样图才能在指定单元格的位置。
.IncrementLeft -30 '相对图片初始位置水平移动正数向右，负数向左
.IncrementTop -30 '相对图片初始位置垂直移动正数向下，负数向上
.IncrementRotation 0 '相对图片初始位置中心旋转
'移动旋转
'大小
.LockAspectRatio = msoFalse '图片纵横比锁定为msoTrue,高度和宽度调一个值整个图就会变
.Left= Cells(i, TPCol).Left
.Top=Cells(i, TPCol).Top
.Height = 200 ' 高度
.Width = 150 '宽度
'大小
End With
ThisWorkbook.Worksheets(1).Cells(i, 1) = myname
End If
myname = Dir
i = i + 1
Loop
ActiveSheet.Pictures.Insert(i).Select '用变量插图片
删除全部图片的一种方法
Dim Sh As Shape '定义一个图形的变量
For Each Sh In ActiveSheet.Shapes '遍游活动表里的所有图形组件
If Sh.Name Like "Picture *" Then '如果图形对象的名称里有“Picture *”通配的往下执行，因为图片对象默认对象名称是Picture 数字
Sh.Select '选择图片名称的对象
Selection.Delete '删除图片对象
End If
Next Sh
