Cropping images depending on image ratio

[Leonvl]

I am trying to import images and then resize and crop them depending on the image ratio.
For one way or the other the cropping does not do what it should do...
Any suggestions?

Sub InsImg1()
    Dim oShape As Shape
    Dim rCell As Range
    Dim sFullName As String
    Dim imgWidth As Double
    Dim imgHeight As Double
    Dim imgTargetWidth As Double
    Dim imgTargetHeight As Double
    Dim imgRatio As Double
    Dim imgTargetRatio As Double
    
    ActiveSheet.Unprotect
    
    imgTargetWidth = 580
    imgTargetHeight = 330
    imgTargetRatio = imgTragetWidth / imgTargetHeight
    
    With Worksheets("Boekje")
        For Each rCell In .Range("A4:ZZ4")
            sFullName = rCell.Value
            If Len(rCell) > 0 Then
                If Len(Dir(sFullName, vbNormal)) > 0 Then
                    Set oShape = .Shapes.AddPicture( _
                        Filename:=sFullName, _
                        LinkToFile:=msoFalse, _
                        SaveWithDocument:=msoTrue, _
                        Left:=rCell.Left + 1, _
                        Top:=rCell.Top + 1, _
                        Height:=-1, _
                        Width:=-1)
                    imgWidth = oShape.Width
                    imgHeight = oShape.Height
                    imgRatio = imgWidth / imgHeight
                    If imgWidth / imgHeight > imgTargetRatio Then 'if image is too wide
                            With oShape
                            .Height = imgTargetHeight 'first set the hight to target height
                            .Width = imgWidth * imgTargetHeight / imgHeight 'resize width proportionally
                                With .PictureFormat 'now chop off the excess portion
                                .CropLeft = (oShape.Width - imgTargetWidth) / 2
                                .CropRight = (oShape.Width - imgTargetWidth) / 2
                                End With
                            End With
                        Else
                            With oShape
                            .Width = imgTargetWidth 'first set the width to target width
                            .Height = imgHeight * imgTargetWidth / imgWidth 'resize height proportionally
                                With .PictureFormat 'now chop off the excess portion
                                .CropTop = (oShape.Height - imgTargetHeight) / 2
                                .CropBottom = (oShape.Height - imgTargetHeight) / 2
                                End With
                            End With
                        End If
                        rCell.EntireRow.RowHeight = imgTargetHeight + 1
                    oShape.Select
                    Selection.ShapeRange.ZOrder msoSendToBack
                End If
            End If
        Next rCell
    End With
    
    ActiveSheet.Protect
    
End Sub

 

[Yongle]

I am trying to import images and then resize and crop them depending on the image ratio.
For one way or the other the cropping does not do what it should do...

You did not tells us what "it should do"

Height is the problem ...
What is trimmed ? A, B or C
A top only
B bottom only
C 50% bottom 50% top

Width is the problem
What is trimmed ? D, E or F
D left only
E right only
F 50% right 50% left

 

[Leonvl]

You did not tells us what "it should do"

Height is the problem ...
What is trimmed ? A, B or C
A top only
B bottom only
C 50% bottom 50% top

Width is the problem
What is trimmed ? D, E or F
D left only
E right only
F 50% right 50% left

Hi Yongle,

If the image is too wide, it should crop 50% of the excess of the right and 50% of the left (C)
If the image is too high, it should crop 50% of the excess of the top and 50% of the bottom (F)

Leon

 

[Yongle]

Thanks
Will post amended code tomorrow

 

[Yongle]

Sub Leonvl()
    Dim oShape As Shape, rCell As Range, sFullName As String
    Dim imgTargetWidth As Double, imgTargetHeight As Double
   
    imgTargetWidth = 580
    imgTargetHeight = 330
     
    With Worksheets("Boekje")
        .Unprotect
        For Each rCell In .Range("A4:ZZ4")
            sFullName = rCell.Value
            If Len(rCell) > 0 Then
                Rows(rCell.Row).RowHeight = imgTargetHeight + 1
                Columns(rCell.Column).ColumnWidth = 105
                If Len(Dir(sFullName, vbNormal)) > 0 Then
                'add image
                    Set oShape = .Shapes.AddPicture(Filename:=sFullName, LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, Left:=rCell.Left + 1, Top:=rCell.Top + 1, Height:=-1, Width:=-1)
                    With oShape
                'resize image
                        .LockAspectRatio = msoTrue
                        .Placement = xlMoveAndSize
                        .Width = imgTargetWidth
                        If .Height < imgTargetHeight Then .Height = imgTargetHeight
                        .LockAspectRatio = msoFalse
                   
                'chop off the excess portion
                        With .PictureFormat
                            .CropLeft = (oShape.Width - imgTargetWidth) / 2
                            .CropRight = oShape.Width - imgTargetWidth
                            .CropTop = (oShape.Height - imgTargetHeight) / 2
                            .CropBottom = oShape.Height - imgTargetHeight
                        End With
                        .Top = rCell.Top + 1
                        .Left = rCell.Left + 1
                    End With
                    
                    oShape.Select
                    Selection.ShapeRange.ZOrder msoSendToBack
                End If
            End If
        Next rCell
        .Protect
    End With
End Sub

 

[Leonvl]

Thanks Yongle,
Nice tidy code
The cropping seems to be relative to its original size and not absolute. So if I am using an extremely wide or high image, the result is that this image still is either too wide or too high.
I believe the solutioon must be found in a better understanding of what the basis of .CropLeft .CropRight .CropTop and .Cropbottom is to make sure we are cropping the right amount. Apparently the math "oShape.Width - imgTargetWidth" isnt providing right outcome...

Leon

 

[Yongle]

The cropping seems to be relative to its original size and not absolute. So if I am using an extremely wide or high image, the result is that this image still is either too wide or too high.
I believe the solutioon must be found in a better understanding of what the basis of .CropLeft .CropRight .CropTop and .Cropbottom is to make sure we are cropping the right amount. Apparently the math "oShape.Width - imgTargetWidth" isnt providing right outcome...

- I forgot all about that
- I now remember hitting this paricular gremlin previously!

I will post revised code later

 

[Yongle]

attempt no2

Sub Leonvl()
    Dim oShape As Shape, rCell As Range, sFullName As String
    Dim targetWidth As Double, targetHeight As Double, targetRatio As Double
    Dim imgWidth As Double, imgHeight As Double, imgRatio As Double
    targetWidth = 580
    targetHeight = 330
    targetRatio = targetWidth / targetHeight
    
    With Worksheets("Boekje")
        .Unprotect
        For Each rCell In .Range("A4:ZZ4")
            If Len(rCell) > 0 Then
                sFullName = rCell.Value
                Rows(rCell.Row).RowHeight = targetHeight + 1
                Columns(rCell.Column).ColumnWidth = 105
                If Len(Dir(sFullName, vbNormal)) > 0 Then
                'add image
                    Set oShape = .Shapes.AddPicture(Filename:=sFullName, LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, Left:=rCell.Left + 1, Top:=rCell.Top + 1, Height:=-1, Width:=-1)
                    With oShape
                        .ScaleWidth 1, True
                        imgWidth = .Width
                        imgHeight = .Height
                        imgRatio = imgWidth / imgHeight
                'chop off the excess portion
                        With .PictureFormat
                            Select Case imgRatio > targetRatio
                            Case True
                                .CropLeft = (imgWidth - imgHeight * targetRatio) / 2
                                .CropRight = .CropLeft
                            Case False
                                .CropTop = (imgHeight - imgWidth / targetRatio) / 2
                                .CropBottom = .CropTop
                            End Select
                        End With
                        .LockAspectRatio = msoTrue
                        .Height = targetHeight
                        .Top = rCell.Top + 1
                        .Left = rCell.Left + 1
                    End With
                    oShape.Select
                    Selection.ShapeRange.ZOrder msoSendToBack
                End If
            End If
        Next rCell
        .Protect
    End With
End Sub

 

[Leonvl]

Hi Yongle,

This does the magic! Just with a little adjustment: the "sFullName = rCell.Value" must go before "If Len(rCell) > 0", not after....
Many thanks!

Leon

Sub Leonvl()
    Dim oShape As Shape, rCell As Range, sFullName As String
    Dim targetWidth As Double, targetHeight As Double, targetRatio As Double
    Dim imgWidth As Double, imgHeight As Double, imgRatio As Double
    targetWidth = 580
    targetHeight = 330
    targetRatio = targetWidth / targetHeight
    
    With Worksheets("Boekje")
        .Unprotect
        For Each rCell In .Range("A4:ZZ4")
            sFullName = rCell.Value
            If Len(rCell) > 0 Then
                Rows(rCell.Row).RowHeight = targetHeight + 1
                Columns(rCell.Column).ColumnWidth = 105
                If Len(Dir(sFullName, vbNormal)) > 0 Then
                'add image
                    Set oShape = .Shapes.AddPicture(Filename:=sFullName, LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, Left:=rCell.Left + 1, Top:=rCell.Top + 1, Height:=-1, Width:=-1)
                    With oShape
                        .ScaleWidth 1, True
                        imgWidth = .Width
                        imgHeight = .Height
                        imgRatio = imgWidth / imgHeight
                'chop off the excess portion
                        With .PictureFormat
                            Select Case imgRatio > targetRatio
                            Case True
                                .CropLeft = (imgWidth - imgHeight * targetRatio) / 2
                                .CropRight = .CropLeft
                            Case False
                                .CropTop = (imgHeight - imgWidth / targetRatio) / 2
                                .CropBottom = .CropTop
                            End Select
                        End With
                        .LockAspectRatio = msoTrue
                        .Height = targetHeight
                        .Top = rCell.Top + 1
                        .Left = rCell.Left + 1
                    End With
                    oShape.Select
                    Selection.ShapeRange.ZOrder msoSendToBack
                End If
            End If
        Next rCell
        .Protect
    End With
End Sub

 

[Yongle]

Glad it works for you
Thanks for the feedback

On reflection, you could make this amendment to the code

Select Case imgRatio
    Case Is > targetRatio
        .CropLeft = (imgWidth - imgHeight * targetRatio) / 2
        .CropRight = .CropLeft
    Case Is < targetRatio
        .CropTop = (imgHeight - imgWidth / targetRatio) / 2
        .CropBottom = .CropTop
End Select