Macro Fit a image in a cell acording to his size.

[Merenat]

As this is my first message here and I don't see any place to make it, i Want to say Hello word and thanks for the amazing job all you are doing for teaching us.

I have a question with a macro that works well, but I can't adapt it to improve what I want.

I have a book that the first sheet is an index of the following sheets, and in the following sheets there is a more detailed explanation. In the first there is a brief descriptive image and in the others there are three images of different sizes. They all fit the size of the cell or the range designated for it.

This code insert the image with a specific size in the first sheet, but I can't figure how in the hell make it fit to the activecell height & widht. And I'm not sure wich option is better, make four macros with diferent outputsizes or one that put the image in the selected range.

Public Sub Add_Pic()
 
Dim oActive As Worksheet
Dim oShape As Shape
Dim vSelection As Variant
Dim lTop As Long
Dim lLeft As Long
    
Set oActive = ThisWorkbook.ActiveSheet
    
'Allow the user to browse for an image file
vSelection = Application.GetOpenFilename("Graphics files (*.gif;*.jpg), *.gif;*.jpg")
If vSelection = False Then
    MsgBox "Please select a photo"
    Exit Sub
End If
   
'Offset the top left corner of the image to be in the
lTop = Selection.Top + 3
lLeft = Selection.Left + 5
 
'Insert the image at the fixed size 80 X 80 and then reset size to 100%
Set oShape = oActive.Shapes.AddPicture(vSelection, True, True, lLeft, lTop, 125, 83)
oShape.ScaleHeight 1, msoFalse
oShape.ScaleWidth 1, msoFalse
oShape.Placement = xlMoveAndSize
 
'Name the shape "Picture" with the cell address appended
oShape.Name = "Picture" & Selection.Address

End Sub

I know it may seem silly to you but it has blocked me.

Thanks for the help.

 

[DanteAmor]

Welcome to the MrExcel forum. Please accept my warmest greetings and sincere hope that all is well.

Try the following:

Public Sub Add_Pic()
  Dim oActive As Worksheet
  Dim oShape As Shape
  Dim vSelection As Variant
  Dim lTop As Long, lLef As Long, lWid As Long, lHei As Long
  Dim rng As Range
      
  Set oActive = ThisWorkbook.ActiveSheet
  Set rng = Selection
  
  'Allow the user to browse for an image file
  vSelection = Application.GetOpenFilename("Graphics files (*.gif;*.jpg), *.gif;*.jpg")
  If vSelection = False Then
      MsgBox "Please select a photo"
      Exit Sub
  End If
     
  'Centered within cell selection
  lTop = rng.Top + 2
  lLef = rng.Left + 2
  lWid = rng.Width - 4
  lHei = rng.Height - 4
   
  'Insert the image at the fixed size 80 X 80 and then reset size to 100%
  Set oShape = oActive.Shapes.AddPicture(vSelection, True, True, lLef, lTop, lWid, lHei)
  oShape.Placement = xlMoveAndSize
   
  'Name the shape "Picture" with the cell address appended
  oShape.Name = "Picture" & Selection.Address
End Sub

If you want it adjusted to the cell selection, use the following:

  lTop = rng.Top 
  lLef = rng.Left 
  lWid = rng.Width 
  lHei = rng.Height

Let me know the result and I'll get back to you as soon as I can.
Sincerely
Dante Amor
----- --

 

[Merenat]

It works like a charm.

I still have a lot to learn. It is one thing to see it when it is written and another to write it myself.

Thank you a lot DanteAmor.