VBA-Track Picture

 

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