Save images from excel file VBA

[R12345]

Hi experts,

I have an excel file with images in column A and text to become image names in column B.

This code allows me to save all images from excel in .png format to a selected folder which is great.

Sub SaveImages()

    'the location to save all the images
    Const destFolder$ = "C:\users\...\desktop\"

    Dim ws As Worksheet
    Set ws = ThisWorkbook.Worksheets("sheet1")

    Dim ppt As Object, ps As Variant, slide As Variant

    Set ppt = CreateObject("PowerPoint.application")
    Set ps = ppt.presentations.Add
    Set slide = ps.slides.Add(1, 1)

    Dim shp As Shape, shpName$
    For Each shp In ws.Shapes
        shpName = destFolder & shp.TopLeftCell.Offset(1, 1) & ".png"
        shp.Copy
        With slide
            .Shapes.Paste
            .Shapes(.Shapes.Count).Export shpName, 2
            .Shapes(.Shapes.Count).Delete
        End With
    Next shp

    With ps
        .Saved = True
        .Close
    End With
    ppt.Quit
    Set ppt = Nothing

End Sub

The issue I have is after image gets saved, it is very small. Is there a way I can save images in smaller power point slides so I wont have so much white space around it? (Image with this issue attached). Thanks!