# Help cropping image to 1:1 Aspect Ratio

#### ViperDriver35

##### New Member
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!

### Excel Facts

Lock one reference in a formula
Need 1 part of a formula to always point to the same range? use \$ signs: \$V\$2:\$Z\$99 will always point to V2:Z99, even after copying

#### hennahairgel

##### Board Regular
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
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
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

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
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
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!

Replies
9
Views
115
Replies
1
Views
99
Replies
4
Views
183
Replies
1
Views
348
Replies
4
Views
2K