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