Help cropping image to 1:1 Aspect Ratio

[ViperDriver35]

Hello,

I have searched the internet and these forums pretty extensively trying to come up with an answer to my question. Essentially, I am trying to take an image with an aspect ratio other than 1:1 and crop it to an 8 inch by 8 inch size. I have found that 72 points should correspond to 1 inch but in practice this does not seem to be working. Here is the VBA code I am currently using:

With shp
Width = .Width
Height = .Height
TCrop = Width - Height
Hcrop = TCrop / 2
End With
With .PictureFormat
.CropLeft = Hcrop
.CropTop = 0
.CropBottom = 0
.CropRight = Hcrop
End With

I am trying to crop 1/2 of the excess image from each side of the picture. To me, this code should accomplish it but it is not delivering a final image with a 1:1 aspect ratio. Additionally, it is not delivering consistent results from pictures with different aspect ratios (i.e. 16:9 vs 4:3 do not end up with the same aspect ratio after cropping).

I would appreciate any input on this as I have run out of troubleshooting ideas myself. Thank you!

 

[hennahairgel]

You've assumed that the image is always landscape, i.e. the width is greater than the height and hence you're needed to crop the width.

You could resolve this as:

If Width > Height then
    Hcrop = (Width - Height)/2
    Vcrop = 0
Else
    Hcrop = 0
    Vcrop = (Height - Width) / 2
End if

Then update the cropping bit to:

.CropLeft = Hcrop
.CropTop = Vcrop
.CropBottom = Vcrop
.CropRight = Hcrop

 

[ViperDriver35]

Thanks for the response! Unfortunately, this still isn't working as I would hope.

Here is the entire code I am using:

Sub SimpleCrop()


Dim Width As Integer
Dim Height As Integer
Dim TCrop As Integer
Dim Hcrop As Integer
Dim shp As Shape
Dim sngMemoLeft As Single
Dim sngMemoTop As Single
Dim i As Integer
i = 0
For Each shp In ActiveSheet.Shapes
i = i + 1
With shp
If .Type = 13 Then
With shp
Width = .Width
Height = .Height
If Width > Height Then
    Hcrop = (Width - Height) / 2
    Vcrop = 0
Else
    Hcrop = 0
    Vcrop = (Height - Width) / 2
End If
End With
With .PictureFormat
.CropLeft = Hcrop
.CropTop = Vcrop
.CropBottom = Vcrop
.CropRight = Hcrop
End With
End If
End With
Next shp
End Sub

I am using two images to test the code. The first image is originally 6.61" x 11.0" and crops to 6.61" x 8.03" using the above code. The second image is originally 5.24" x 11.0" and crops to 5.24" x 6.94" using the same code. The code is not delivering the expected results and even more confusingly it is not delivering consistent results from images with different initial aspect ratios. Anymore help would be absolutely appreciated. Thanks again!

 

[Anthony47]

Posted in the duplicated discussion:

Could you share a sample workbook containing an Image, the macro, the image resulting from running the macro and the description of what is wrong (with respect to what you wish to obtain) in the resulting image?
For sharing a file you could use a file sharing service, eg dropbox or filedropper.com

Bye

 

[Anthony47]

It is always difficult to work on a macro that doesn't perform according the user's expectation, if you don't know which is the user expectations...

By reading your code my best guess is that you are trying to crop your images to a square.
If this is the case, then you didn't take into consideration that the cropped measures refers to the "original size" of the picture, wereas images are normally "scaled" by Excel when they are embedded. What is bad is that the scaling factor (in my understanding) cannot be foreseen; what is worse is that the scaling factor (in my knowledge) cannot be read from the picture.
After this foreword, the following macro should crop the images to a square:

Sub XACrop()
Dim cWidth As Integer, cWAspect As Single, cHeight As Integer, cHAspect As Single
Dim vCrop As Integer
Dim hCrop As Integer
Dim shp As Shape
''Dim sngMemoLeft As Single
''Dim sngMemoTop As Single
Dim i As Integer
i = 0
For Each shp In ActiveSheet.Shapes
'Calculate scaling factors:
    shp.LockAspectRatio = msoFalse
    cWidth = shp.Width
    cHeight = shp.Height
    shp.ScaleWidth 1, msoTrue
    cWAspect = cWidth / shp.Width
    shp.ScaleHeight 1, msoTrue
    cHAspect = cHeight / shp.Height
'
    i = i + 1       '???
    With shp
        If .Type = 13 Then
            With shp
                cWidth = .Width
                cHeight = .Height
                If cWidth > cHeight Then
                    hCrop = (cWidth - cHeight) / 2
                    vCrop = 0
                Else
                    hCrop = 0
                    vCrop = (cHeight - cWidth) / 2
                End If
            End With
            With .PictureFormat
                .CropLeft = hCrop
                .CropTop = vCrop
                .CropBottom = vCrop
                .CropRight = hCrop
            End With
'restore aspect ratios:
    shp.ScaleWidth cWAspect, msoTrue
    shp.ScaleHeight cHAspect, msoTrue
    End If
    End With
Next shp
End Sub

If this is the case, then etc etc

If my best guess was wrong, well I already knew I am not a clairvoyant, and it is your turn to explain what you are trying to achieve...

Bye

 

[ViperDriver35]

That is exactly what I am trying to do. Thank you for all of the help on this. I attempted using your code and get a Run-time error: "The RelativeToOrignalSize argument applies only to a picture or an OLE object" at the shp.scalewidth 1, msoTrue step.

 

[ViperDriver35]

Nevermind! It works just fine! I had some other nonpicture shapes in the file so I just added an additional If condition and works great! Thanks so much for the help!