resize picture to cell size

[Kade]

hi all,

I have searched for ages and can find plenty of references to resize a cell to a picture....... but I want a picture to resize to the cells size.

I do not want to use a cell note
the size of the cells have been set at ht 225 width 58

i understand that what I want may distort the image but thats ok for my need

thanks to the board I currently use this, which is great , but only if the images imported are the same size

Sub InsertPicture()

Dim myPicture As String

myPicture = Application.GetOpenFilename _
("Pictures (*.gif; *.jpg; *.bmp; *.tif),*.gif; *.jpg; *.bmp; *.tif", , "Select Picture to Import")
If myPicture <> "" Then
ActiveSheet.Pictures.Insert (myPicture)
ActiveSheet.Shapes(ActiveSheet.Shapes.Count).Select
Selection.ShapeRange.ScaleWidth 0.64, msoFalse, msoScaleFromTopLeft
Selection.ShapeRange.ScaleHeight 0.64, msoFalse, msoScaleFromTopLeft
Selection.ShapeRange.ScaleHeight 0.97, msoFalse, msoScaleFromTopLeft

End If
End Sub

I presume it is the last three lines I need to rejig.

tia kd

 

[NateO]

Hello, try adapting the following:

<font face=Courier New>myPic <SPAN style="color:darkblue">As</SPAN> <SPAN style="color:darkblue">Object</SPAN>
<SPAN style="color:darkblue">Set</SPAN> myPic = ws.Pictures.Insert(MyDir & Nme)
<SPAN style="color:darkblue">With</SPAN> myPic
    .Top = ws.[a1].Top
    .Left = ws.[a1].Left
    .ShapeRange.LockAspectRatio = msoFalse
    .ShapeRange.Height = ws.[a1].RowHeight
    .ShapeRange.Width = ws.[a1].Width
<SPAN style="color:darkblue">End</SPAN> <SPAN style="color:darkblue">With</SPAN>
<SPAN style="color:darkblue">Set</SPAN> myPic = <SPAN style="color:darkblue">Nothing</SPAN></FONT>

Hope this helps.

Edit: pulled a comment that didn't make sense.

 

[Kade]

thanks Nate

Am i seeing things or did u edit your post?

this has helped a lot but I when I run it, it doesn't fill to the width (height and top left fine). Can u see any probs in what I have

btw it seems to be about a ratio of 5.5 to 6 times filling entire width, but is not consistant

tia kd


With Selection
.ShapeRange.LockAspectRatio = msoFalse
.Top = ActiveCell.Top

.Left = ActiveCell.Left

.ShapeRange.Height = ActiveCell.RowHeight
.ShapeRange.Width = ActiveCell.ColumnWidth

End With

 

[Kade]

Hi all

with a little help from my friends and trial and error this does what I want.

Imports selected picture, and resizes the picture to what ever the cell size is.

Can anyone explain why I need to multiply by 5.25 and add 4 to make it fit width wise (it appears to work for any cell width I try)
.ShapeRange.Width = ActiveCell.ColumnWidth * 5.25 + 4

Is it something to do with the units of cell width????, or do I just accept that it works


Sub InsertPicture()

Dim myPicture As String

myPicture = Application.GetOpenFilename _
("Pictures (*.gif; *.jpg; *.bmp; *.tif),*.gif; *.jpg; *.bmp; *.tif", , "Select Picture to Import")
If myPicture <> "" Then
ActiveSheet.Pictures.Insert (myPicture)
ActiveSheet.Shapes(ActiveSheet.Shapes.Count).Select

With Selection

.ShapeRange.LockAspectRatio = msoFalse
.ShapeRange.Height = ActiveCell.RowHeight
.ShapeRange.Width = ActiveCell.ColumnWidth * 5.25 + 4
.Placement = xlMoveAndSize


End With
End If
End Sub

 

[NateO]

Hello, I did modify my post.

Instead of using columnwidth, use width like I did, this will return the number you want.

Oh no need to select the object, just set it on the insert and work with it from there.

 

[Kade]

Thanks Nate, I should have read your answer more carefully , I have been trying to do that for ages it is a great assistance to me for doing reports.

kd