Help cropping image to 1:1 Aspect Ratio

ViperDriver35

New Member
Joined
Mar 18, 2018
Messages
7
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!
 

Some videos you may like

Excel Facts

Save Often
If you start asking yourself if now is a good time to save your Excel workbook, the answer is Yes

hennahairgel

Board Regular
Joined
Feb 19, 2002
Messages
63
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:
Code:
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:
Code:
.CropLeft = Hcrop
.CropTop = Vcrop
.CropBottom = Vcrop
.CropRight = Hcrop
 

ViperDriver35

New Member
Joined
Mar 18, 2018
Messages
7
Thanks for the response! Unfortunately, this still isn't working as I would hope.

Here is the entire code I am using:

Code:
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

Well-known Member
Joined
Mar 29, 2006
Messages
1,969
Posted in the duplicated discussion:
Anthony47 said:
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

Well-known Member
Joined
Mar 29, 2006
Messages
1,969

ADVERTISEMENT

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:
Code:
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

Anthony said:
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

New Member
Joined
Mar 18, 2018
Messages
7
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

New Member
Joined
Mar 18, 2018
Messages
7
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!
 

Watch MrExcel Video

Forum statistics

Threads
1,118,791
Messages
5,574,312
Members
412,586
Latest member
Medhum
Top