Leonvl
New Member
- Joined
- Apr 26, 2016
- Messages
- 20
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?
For one way or the other the cropping does not do what it should do...
Any suggestions?
VBA Code:
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