Sub Save_Object_As_Picture()
    Dim avFiles, li As Long, oObj As Object, wsSh As Worksheet
    Dim sBookName As String, sName As String
 
    avFiles = Application.GetOpenFilename("Excel Files(*.xls*),*.xls*", , "Выбрать файлы", , True)
    If VarType(avFiles) = vbBoolean Then Exit Sub
 
    On Error Resume Next
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
 
    For li = LBound(avFiles) To UBound(avFiles)
        Workbooks.Open avFiles(li)
        sBookName = ActiveWorkbook.Name
        For Each wsSh In Sheets
            For Each oObj In wsSh.Shapes
                If oObj.Type = 13 Then
                    '13 – картинки
                    '1 – автофигуры
                    '3 – диаграммы
                    oObj.Copy
                    Workbooks.Add
                    ActiveWorkbook.SaveAs ThisWorkbook.Path & Application.PathSeparator & "TempBook.xls"
                    sName = ThisWorkbook.Path & Application.PathSeparator & sBookName & "_" & wsSh.Name & "_" & oObj.Name
                    ActiveSheet.Paste
                    With ActiveSheet.ChartObjects.Add(0, 0, oObj.Width, oObj.Height).Chart
                        .Paste
                        .Export Filename:=sName & ".jpg", FilterName:="JPG"
                    End With
                    ActiveWorkbook.ChangeFileAccess xlReadOnly
                    Kill ActiveWorkbook.FullName
                    ActiveWorkbook.Close 0
                End If
            Next oObj
        Next wsSh
        ActiveWorkbook.Close 0
    Next li
    Set oObj = Nothing: Set wsSh = Nothing
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    MsgBox "Объекты сохранены в папке: " & ThisWorkbook.Path, vbInformation, "www.excel-vba.ru"
End Sub