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