Hi Guys,


I'm trying to chop a huge picture on a worksheet, so that it fits
exately into a square autofigure on the same worksheet.

The code I'm using is:

Counter = 0
Do While WS.Shapes(PictureName).Left < WS.Shapes(ShapeName).Left
WS.Shapes(PictureName).PictureFormat.CropLeft = _
WS.Shapes(PictureName).PictureFormat.CropLeft + 0.28
Counter = Counter + 1
If Counter 10000 Then Exit Do
Loop

....and the code works fine :-)

It chops the picture in the worksheet so that the left side of the
picture is exately at the left side of the autofigure...

....but...

....for sone strange reason the picture get distored, because the picture
aparrently automatically changes size during the process?!?

I've tried to avoid this by turning of aspect ratio, with
LockAspectRatio = msoFalse, but to no use...

And the absolutely worst thing is, that the units used for chopping are
not the same units used for sizing, so I can't resize according to the
choping afterwards!!!


What am I doing wrong - please, help???


TIA,

CE

I'd use a Frame as a container that's sized how I want/need, then
insert the pic via its ".AddPicture" method. AFAIK, the pic will auto
size to fit the shape object whenever you make changes to the pic or
the container.

--
Garry

Free usenet access at http://www.eternal-september.org
Classic VB Users Regroup!
comp.lang.basic.visual.misc
microsoft.public.vb.general.discussion

Thanks for you response...

But, problem is, that I don't want to resize the picture - that would
have been easy :-)

I really want to chop the picture, since I only need part of the
picture, and it need to be done in Excel, since the original picture may
not be modified...

I'm still guessing that I need to find either the re-size solution or
the unit conversion, but it would be nice if someone know the solution,
instead of me inventing the wheel once again :-)

Thanks,

CE


Den 20.12.2012 23:36, GS skrev:
I'd use a Frame as a container that's sized how I want/need, then insert
the pic via its ".AddPicture" method. AFAIK, the pic will auto size to
fit the shape object whenever you make changes to the pic or the container.

Charlotte E. explained :
Thanks for you response...

But, problem is, that I don't want to resize the picture - that would have
been easy :-)

I really want to chop the picture, since I only need part of the picture, and
it need to be done in Excel, since the original picture may not be
modified...

I'm still guessing that I need to find either the re-size solution or the
unit conversion, but it would be nice if someone know the solution, instead
of me inventing the wheel once again :-)

Thanks,

CE


Den 20.12.2012 23:36, GS skrev:
I'd use a Frame as a container that's sized how I want/need, then insert
the pic via its ".AddPicture" method. AFAIK, the pic will auto size to
fit the shape object whenever you make changes to the pic or the container.

Charlotte,
Any cropping I've done has been directly to the pic object itself, and
it behaves as expected. I don't use containers for most pics because I
always want their TopLeft at a specific cell address. Note that I do
this manually and so wouldn't be aware of the nuances attached to using
VBA. Sorry I can't be of more help...

--
Garry

Free usenet access at http://www.eternal-september.org
Classic VB Users Regroup!
comp.lang.basic.visual.misc
microsoft.public.vb.general.discussion

Charlotte,

I think that the routine copied below will work. To recreate your workbook, I pasted a picture to the sheet and place a rectangle shape over it. After running the code below, the picture is cropped to fit inside the box. In addition, the code displays the compress picture dialog in case you would like to compress the picture afterwards. Simply comment out (or delete) those two lines if you dont' want to include that step.

Hope this helps.

Ben

Sub CropIt()
Dim sShape As Shape
Dim sPicture As Shape

Set sShape = Sheet1.Shapes("Rectangle 2")
Set sPicture = Sheet1.Shapes("Picture 3")

With sPicture.PictureFormat.Crop
.ShapeLeft = sShape.Left
.ShapeTop = sShape.Top
.ShapeWidth = sShape.Width
.ShapeHeight = sShape.Height
End With

'Comment out next two lines if you do not want to show compress dialog
sPicture.Select
Application.CommandBars.ExecuteMso "PicturesCompress"

Set sShape = Nothing
Set sPicture = Nothing

End Sub

Thanks, Ben, but your code is not working???

I get a 'Method or data member not found'

....in this line: sPicture.PictureFormat.Crop
and the word '.Crop' is highlighted.

Only crop options I have a

..CropBottom
..CropLeft
..CropRight
..CropTop

Am I missing a reference or something???


CE



Den 21.12.2012 19:57, Ben McClave skrev:
Charlotte,

I think that the routine copied below will work. To recreate your workbook, I pasted a picture to the sheet and place a rectangle shape over it. After running the code below, the picture is cropped to fit inside the box. In addition, the code displays the compress picture dialog in case you would like to compress the picture afterwards. Simply comment out (or delete) those two lines if you dont' want to include that step.

Hope this helps.

Ben

Sub CropIt()
Dim sShape As Shape
Dim sPicture As Shape

Set sShape = Sheet1.Shapes("Rectangle 2")
Set sPicture = Sheet1.Shapes("Picture 3")

With sPicture.PictureFormat.Crop
.ShapeLeft = sShape.Left
.ShapeTop = sShape.Top
.ShapeWidth = sShape.Width
.ShapeHeight = sShape.Height
End With

'Comment out next two lines if you do not want to show compress dialog
sPicture.Select
Application.CommandBars.ExecuteMso "PicturesCompress"

Set sShape = Nothing
Set sPicture = Nothing

End Sub

Charlotte,

I am using 2010, and apparently the method I used is only available in 2010 or later. I spent some time trying to work out a way to do this in 2007. Below is my best effort, but it may not be the best way. Give it a try and see if this works for your needs.

Ben

Sub CropIt()
Dim sShape As Shape
Dim sPicture As Shape

Set sShape = Sheet1.Shapes("Rectangle 1")
Set sPicture = Sheet1.Shapes("Picture 4")

With sPicture.PictureFormat 'Reset picture size, then crop to shape size
.CropBottom = 0
.CropLeft = 0
.CropRight = 0
.CropTop = 0
.CropRight = sPicture.Left + sPicture.Width - sShape.Left - sShape.Width
.CropBottom = sPicture.Top + sPicture.Height - sShape.Top - sShape.Height
.CropLeft = sShape.Left - sPicture.Left
.CropTop = sShape.Top - sPicture.Top
End With

End Sub

Hi Ben,


Sorry for a late reply - you know: Xmas, New Year, Vacation and stuff :-)

Still doesn't work, so for now, I might need to do some calculation to
find the factor between shape and image sizes...

But, thanks for your effort anyway...


CE



Den 22.12.2012 06:15, Ben McClave skrev:
Charlotte,

I am using 2010, and apparently the method I used is only available in 2010 or later. I spent some time trying to work out a way to do this in 2007. Below is my best effort, but it may not be the best way. Give it a try and see if this works for your needs.

Ben

Sub CropIt()
Dim sShape As Shape
Dim sPicture As Shape

Set sShape = Sheet1.Shapes("Rectangle 1")
Set sPicture = Sheet1.Shapes("Picture 4")

With sPicture.PictureFormat 'Reset picture size, then crop to shape size
.CropBottom = 0
.CropLeft = 0
.CropRight = 0
.CropTop = 0
.CropRight = sPicture.Left + sPicture.Width - sShape.Left - sShape.Width
.CropBottom = sPicture.Top + sPicture.Height - sShape.Top - sShape.Height
.CropLeft = sShape.Left - sPicture.Left
.CropTop = sShape.Top - sPicture.Top
End With

End Sub

On Thu, 03 Jan 2013 09:51:12 +0100, "Charlotte E." wrote:

snip long lines (Usenet rules)

Ben

Sub CropIt()
Dim sShape As Shape
Dim sPicture As Shape

Set sShape = Sheet1.Shapes("Rectangle 1")
Set sPicture = Sheet1.Shapes("Picture 4")

With sPicture.PictureFormat 'Reset picture size, then crop to shape size
.CropBottom = 0
.CropLeft = 0
.CropRight = 0
.CropTop = 0
.CropRight = sPicture.Left + sPicture.Width - sShape.Left - sShape.Width
.CropBottom = sPicture.Top + sPicture.Height - sShape.Top - sShape.Height
.CropLeft = sShape.Left - sPicture.Left
.CropTop = sShape.Top - sPicture.Top
End With

End Sub


I found this a long time ago, and it scales a picture to fit within the
range I declare, AFAICT.

It was a while ago, so my familiarity with its workings is not current.

I am sure that you could find the pieces which will give your code the
effect you desire.


To quote (attributes not related to me in any way):

» Insert pictures using VBA in Microsoft Excel

VBA macro tip contributed by Erlandsen Data Consulting offering Microsoft
Excel Application development, template customization, support and
training solutions

CATEGORY: General Topics in VBA

VERSIONS: All Microsoft Excel Versions

With the macro below you can insert pictures at any range in a worksheet.
The picture can be centered horizontally and/or vertically.

Sub TestInsertPicture()
InsertPicture "C:\FolderName\PictureFileName.gif", _
Range("D10"), True, True
End Sub

Sub InsertPicture(PictureFileName As String, TargetCell As Range, _
CenterH As Boolean, CenterV As Boolean)
' inserts a picture at the top left position of TargetCell
' the picture can be centered horizontally and/or vertically
Dim p As Object, t As Double, l As Double, w As Double, h As Double
If TypeName(ActiveSheet) < "Worksheet" Then Exit Sub
If Dir(PictureFileName) = "" Then Exit Sub
' import picture
Set p = ActiveSheet.Pictures.Insert(PictureFileName)
' determine positions
With TargetCell
t = .Top
l = .Left
If CenterH Then
w = .Offset(0, 1).Left - .Left
l = l + w / 2 - p.Width / 2
If l < 1 Then l = 1
End If
If CenterV Then
h = .Offset(1, 0).Top - .Top
t = t + h / 2 - p.Height / 2
If t < 1 Then t = 1
End If
End With
' position picture
With p
.Top = t
.Left = l
End With
Set p = Nothing
End Sub

With the macro below you can insert pictures and fit them to any range in
a worksheet.

Sub TestInsertPictureInRange()
InsertPictureInRange "C:\FolderName\PictureFileName.gif", _
Range("B5:D10")
End Sub

Sub InsertPictureInRange(PictureFileName As String, TargetCells As Range)
' inserts a picture and resizes it to fit the TargetCells range
Dim p As Object, t As Double, l As Double, w As Double, h As Double
If TypeName(ActiveSheet) < "Worksheet" Then Exit Sub
If Dir(PictureFileName) = "" Then Exit Sub
' import picture
Set p = ActiveSheet.Pictures.Insert(PictureFileName)
' determine positions
With TargetCells
t = .Top
l = .Left
w = .Offset(0, .Columns.Count).Left - .Left
h = .Offset(.Rows.Count, 0).Top - .Top
End With
' position picture
With p
.Top = t
.Left = l
.Width = w
.Height = h
End With
Set p = Nothing
End Sub

In case anyone else is interested.

Thank you for your help, and the need for VB qualification.
This gives the terms "Visual Basic" a whole new meaning... or not. :-]

I found the refined result I came up with...

Sub Pop()
' This pops the image in from the data archive,
'

On Error Resume Next
ActiveSheet.Shapes("Popped").Delete
InsertPicture Range("B6").Value, _
Range("B6:G33"), "Popped"
End Sub

Sub InsertPicture(PictureFileName As String, TargetCells As Range,
picName As String)
' inserts a picture and resizes it to fit the TargetCells range
Dim p As Object, t As Double, l As Double, w As Double, h As Double
If TypeName(ActiveSheet) < "Worksheet" Then Exit Sub
If Dir(PictureFileName) = "" Then Exit Sub
' import picture
Set p = ActiveSheet.Pictures.Insert(PictureFileName)
'Name the picture so you can delete it later....
p.Name = picName
' determine positions
With TargetCells
t = .Top
l = .Left
w = .Offset(0, .Columns.Count).Left - .Left
h = .Offset(.Rows.Count, 0).Top - .Top
End With
' position picture
With p
.Top = t
.Left = l
.Width = w
.Height = h
End With
Set p = Nothing
End Sub



On Thu, 03 Jan 2013 09:51:12 +0100, "Charlotte E." wrote:

snip long lines (Usenet rules)

Ben

Sub CropIt()
Dim sShape As Shape
Dim sPicture As Shape

Set sShape = Sheet1.Shapes("Rectangle 1")
Set sPicture = Sheet1.Shapes("Picture 4")

With sPicture.PictureFormat 'Reset picture size, then crop to shape size
.CropBottom = 0
.CropLeft = 0
.CropRight = 0
.CropTop = 0
.CropRight = sPicture.Left + sPicture.Width - sShape.Left - sShape.Width
.CropBottom = sPicture.Top + sPicture.Height - sShape.Top - sShape.Height
.CropLeft = sShape.Left - sPicture.Left
.CropTop = sShape.Top - sPicture.Top
End With

End Sub