Sub reset_save_images()

    'reset
    Dim shape As Excel.shape

    For Each shape In ActiveSheet.Shapes
        With shape
            .ScaleHeight 1#, True, msoScaleFromTopLeft
            .ScaleWidth 1#, True, msoScaleFromTopLeft
        End With
    Next
    
    'save
    Dim li As Long, oObj As shape, wsSh As Worksheet, wsTmpSh As Worksheet
    Dim sImagesPath As String, sName As String
    
    sImagesPath = ActiveWorkbook.Path & "\images\" '"
    If Dir(sImagesPath, 16) = "" Then
        MkDir sImagesPath
    End If
    On Error Resume Next
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Set wsSh = ActiveSheet
    Set wsTmpSh = ActiveWorkbook.Sheets.Add
    For Each oObj In wsSh.Shapes
        If oObj.Type = 13 Then
            li = li + 1
            oObj.Copy
            sName = "img" & li
            With wsTmpSh.ChartObjects.Add(0, 0, oObj.Width, oObj.Height).Chart
                .ChartArea.Border.LineStyle = 0
                .Paste
                .Export Filename:=sImagesPath & sName & ".jpg"
                .Parent.Delete
            End With
            oObj.TopLeftCell.Value = sName
            oObj.Delete
        End If
    Next oObj
    Set oObj = Nothing: Set wsSh = Nothing
    wsTmpSh.Delete
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    MsgBox "Объекты сохранены в папке: " & sImagesPath, vbInformation
End Sub