Sub ImgQuad()
    Dim h, w, maxSide As Long
    Dim imgName As String
    Dim myImg, myChart, myPicture, IP As Object
    Sheets.Add
    imgName = "сюда вставить путь и имя файла картинки"
    Set myImg = CreateObject("WIA.ImageFile")
    myImg.loadfile imgName
    h = myImg.Height
    w = myImg.Width
    If h > w Then maxSide = h Else maxSide = w
    ActiveSheet.Shapes.AddPicture imgName, False, True, 0, 0, maxSide, maxSide
    Set myPicture = ThisWorkbook.ActiveSheet.Shapes(1)
    myPicture.PictureFormat.Crop.PictureHeight = h
    myPicture.PictureFormat.Crop.PictureWidth = w
    Set myChart = ActiveSheet.ChartObjects.Add(Left:=0, Top:=0, Width:=maxSide, Height:=maxSide)
    myChart.ShapeRange.Line.Visible = msoFalse
    myPicture.Copy
    myChart.Activate
    ActiveChart.Paste
    myChart.Chart.Export imgName
    Set IP = CreateObject("WIA.ImageProcess")
    IP.Filters.Add IP.FilterInfos("Scale").FilterID
    IP.Filters(1).Properties("MaximumWidth") = maxSide
    IP.Filters(1).Properties("MaximumHeight") = maxSide
    Set myImg = IP.Apply(myImg)
    Kill imgName
    myImg.SaveFile imgName
    myChart.Delete
    myPicture.Delete
    Application.DisplayAlerts = False
    ActiveSheet.Delete
    Application.DisplayAlerts = True
End Sub