Excel VBA 從Excel中批量導出圖片

Sub 產品圖片導出重新對應命名()
    Dim Ad$, FileName$, sfolder$, Shp As Shape, FSO
    Application.ScreenUpdating = False
    On Error Resume Next
    Set FSO = CreateObject("Scripting.FileSystemObject")
        
    sfolder = "\\192.168.1.239\05采購組\圖片2"
    
    '  If Len(Dir(sfolder, vbDirectory)) = 0 Then  '判斷文件夾是否已經存在
    '  MkDir (sfolder) '創建文件夾
    Application.DisplayAlerts = False '//關閉系統提示

    For Each sh In ActiveWorkbook.Worksheets
        ActiveWorkbook.sh.Activate
        For Each shap In sh.Shapes  '//循環所有圖片
            If shap.Type = 13 Then   '13表示類型為圖片
                Set Rng = shap.TopLeftCell  '//Range 對象，它代表位於指定對象左上角下方的單元格
                shap.Copy
                With sh.ChartObjects.Add(0, 0, shap.Width, shap.Height).Chart  '//建立一個新圖片
                    .Paste  '//將復制的圖片放進去
                    ll = sh.Cells(Rng.Row, 2).Value & ".png"
                    'MsgBox ll & Rng.Row, , "當前圖片名稱"
                    's = sh.cell(Rng.Row, 4)
                    'MsgBox s, , "當前圖片名稱"
                    .Export sfolder & "\" & ll  '//導出為圖片格式，如JPG，GIF
                .Parent.Delete   '//刪除自己建立的圖片
                End With
            End If
        Next
    Next
    Application.ScreenUpdating = True '//恢復屏幕刷新
    Application.DisplayAlerts = True '//恢復系統提示
    'MsgBox "導出圖片完成！" & Chr(13) & "導出圖片所在的路徑：" & Chr(13) & sfolder, , "提示"
End Sub