VBA批量导出图片并重命名

 

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.Width = 800改为PIC.ScaleWidth 1, True

'PIC.Height = 800 改为PIC.ScaleHeight 1, True

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