Private Sub 导出图片_Click()

Application.ScreenUpdating = False
On Error Resume Next
MkDir ThisWorkbook.Path & "\图片"

ActiveSheet.Shapes
For Each PIC In Shapes

If PIC.Type = msoPicture Then
RN = PIC.TopLeftCell.Offset(0, 4).Value    '重命名图片,图片和编号之间的距离是4格，编号如果在图片前面则为（0,-4）

PIC.Width = 800   '先放大图片宽800px，自行调整
PIC.Height = 800  '高800px
PIC.Copy

With ActiveSheet.ChartObjects.Add(0, 0, PIC.Width, PIC.Height).Chart  '创建图片
   .Parent.Select
   .Paste
   .Export ThisWorkbook.Path & "\图片\" & RN & ".jpg"
   .Parent.Delete
   End With

End If
       PIC.Width = 100 '导出后缩小图片宽为100PX
       PIC.Height = 100 '高100PX


Next
MsgBox "导出图片完成！"
Application.ScreenUpdating = True
End Sub