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