Excel VBA 从Excel中批量导出图片 - Learning_logs

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