با سلام
کد زیر رو امتحان کنید.
کد:
Option Explicit
Sub ExportAllPictures()
Dim MyChart As Chart
Dim n As Long, shCount As Long
Dim Sht As Worksheet
Dim pictureNumber As Integer
Application.ScreenUpdating = False
pictureNumber = 1
For Each Sht In ActiveWorkbook.Sheets
shCount = Sht.Shapes.Count
If Not shCount > 0 Then Exit Sub
For n = 1 To shCount
If InStr(Sht.Shapes(n).Name, "Picture") > 0 Then
Set MyChart = Charts.Add
MyChart.Name = "TemporaryPictureChart"
Set MyChart = MyChart.Location(Where:=xlLocationAsObject, Name:=Sht.Name)
MyChart.ChartArea.Width = Sht.Shapes(n).Width
MyChart.ChartArea.Height = Sht.Shapes(n).Height
MyChart.Parent.Border.LineStyle = 0
Sht.Shapes(n).Copy
MyChart.ChartArea.Select
MyChart.Paste
MyChart.Export Filename:="C:\Users\User\Desktop" & "\Picture-" & pictureNumber & ".jpg", FilterName:="jpg"
pictureNumber = pictureNumber + 1
Sht.Cells(1, 1).Activate
Sht.ChartObjects(Sht.ChartObjects.Count).Delete
End If
Next
Next Sht
Application.ScreenUpdating = True
End Sub
علاقه مندی ها (Bookmarks)