Shapes.AddPicture method picture auto width keeping fixed height-CodePudding

I have a code that places fixed height and fixed width pictures in cells.

How to modify this VBA to place pictures - auto width in fixed height (80.5) by keeping the original aspect ratio, using this example from Excel Shapes.AddPicture method?

Sub URLPicturesInsert()
    
    Dim Rng As Range, cell As Range, filename As String
    Dim Pshp As Shape
    Dim aUrls() As String
    Dim i As Long
    
    
    Application.ScreenUpdating = False
    Set Rng = ActiveSheet.Range("G2:G5")
    
    On Error Resume Next
    
    For Each cell In Rng
        
        If cell.Value <> "" Then
            aUrls = Split(cell.Value, "|")
            
            For i = LBound(aUrls) To UBound(aUrls)
                filename = Trim(aUrls(i))
                
                ActiveSheet.Shapes.AddPicture _
                filename:=filename, _
                LinkToFile:=msoFalse, _
                SaveWithDocument:=msoTrue, _
                Left:=cell.Left   (i * 80.5), _
                Top:=cell.Top, _
                Width:=80.5, _
                Height:=80.5
    
            Next i
            
            cell.EntireRow.RowHeight = 80.5
            
            cell.Value = ""
            
        End If
        
        
    Next cell

Range("G2").Select
Application.ScreenUpdating = True

MsgBox "Process completed successfully", vbInformation, "Success"

End Sub

CodePudding user response：

You can use Shape.ScaleHeight.

The factor is 80.5 divided by its current height. RelativeToOriginalSize is false, since we're scaling based on its current height, not its original height. Scale can be any of the options based on how it best fits your needs.

An example:

With Sheet1.Shapes("Picture 1")
    .ScaleHeight 80.5 / .Height, msoFalse, msoScaleFromTopLeft
End With

For your code:

    With ActiveSheet.Shapes.AddPicture( _
        fileName:=fileName, _
        LinkToFile:=msoFalse, _
        SaveWithDocument:=msoTrue, _
        Left:=Cell.Left   (i * 80.5), _
        top:=Cell.top, _
        Width:=-1, _
        Height:=-1 _
    )
        .ScaleHeight 80.5 / .Height, msoFalse, msoScaleFromTopLeft
    End With