insert picture

[jonm]

hi, i'm new here so i would appreciate any assistance.

i have a spreadsheet that i would like to have a picture (selected by the
user) inserted into a specific cell. The user will enter data in the
spreadsheet and click a button to initiate the insert. The pictures may be
of varying size but should not exceed 400x400 once inserted into the
spreadsheet. Is this possible?

 

[Joel]

Here is some code I did for somebody else last week. Because your picture is
not square I test for which side is larger and then crop to 150. You have a
choice of croping or scaling the picture to the size you want. below I
cropped. to scale change the Width and Height of the picture instead of the
crop commands.


Sub InsertPict()

PictureName = Application _
.GetOpenFilename("Text Files (*.txt), *.txt")
If PictureName <> False Then

Set pict = ActiveSheet.Pictures. _
Insert(PictureName)
pict.ShapeRange.LockAspectRatio = msoTrue
'pict.ShapeRange.Height = PictureHeight <=deleted
pictwidth = pict.Width
CellWidth = Cells(9, Cell.Column).Width
WidthBorder = CellWidth - pictwidth
pict.Left = Cells(9, Cell.Column).Left + (WidthBorder / 1.8)

PictHeight = pict.Height
CellHeight = Cells(9, Cell.Column).Height
HeightBorder = CellHeight - PictHeight
pict.Top = Cells(9, Cell.Column).Top + (HeightBorder / 1.8)


If pict.Width > pict.Height Then
If pict.Width > CellWidth Then
If pict.Width > 150 Then
Crop = (pict.Width - CellWidth) / 2
pict.ShapeRange.PictureFormat.CropLeft = Crop
pict.ShapeRange.PictureFormat.CropRight = Crop
End If
End If
Else
If CellHeight > pict.Height Then
If pict.Height > 150 Then
Crop = Abs(pict.Height - CellHeight) / 2
pict.ShapeRange.PictureFormat.CropTop = Crop
pict.ShapeRange.PictureFormat.CropBottom = Crop
End If
End If
End If
End If
End Sub