Inserting Picture (macro) - size and position

[Spaztic]

This seems challenging. I'm looking for a macro to run that will:

1. Insert a picture (would bring the user to the screen where they search for their picture)
2. Place the picture in the cell they already had selected (e.g. B2 below)
3. Size/scale the picture automatically to fully fit within the cell
   • Preferred to leave gaps around all 4 edges of the picture to the cells but not a show stopper (see below)...centered?
4. Picture must 'move and size with cells'

With the code I've tried (below), the struggles I've had are:

• Pictures (in horizontal orientation (e.g. B2)) are filling the height of the cell (they go beyond the width)
• Pictures (in the vertical orientation (e.g. B4)) are sizing the top edge as the height of the cell and placing the picture somewhere else in the worksheet
  • NOTE: If I insert a vertical picture using the conventional methods, it goes in the selected cell.

Sub InsertPic()
Dim fNameAndPath As Variant
Dim img As Picture
fNameAndPath = Application.GetOpenFilename
    Set img = ActiveSheet.Pictures.Insert(fNameAndPath)
    With img
       .Left = ActiveCell.Left
       .Top = ActiveCell.Top
       .Width = ActiveCell.Width
       .Height = ActiveCell.Height
       .Placement = 1
       .PrintObject = True
    End With
    
End Sub

 

[Domenic]

I have amended your code as follows...

Sub InsertPic()

    Dim fNameAndPath As Variant
    Dim rng As Range
    Dim img As Picture
  
    fNameAndPath = Application.GetOpenFilename( _
        FileFilter:="Image Files (*.gif;*.jpg;*.png), *.gif;*.jpg;*.png", _
        Title:="Select an Image", _
        ButtonText:="Select")
      
    If fNameAndPath = False Then Exit Sub
  
    Set rng = ActiveCell
  
    Set img = ActiveSheet.Pictures.Insert(fNameAndPath)
    With img
        If .Width > .Height Then
            .Width = rng.Width * 0.8
        Else
            .Height = rng.Height * 0.8
        End If
        .Left = rng.Left + (rng.Width - .Width) / 2
        .Top = rng.Top + (rng.Height - .Height) / 2
       .Placement = 1
       .PrintObject = True
    End With
  
End Sub

You'll notice that I have added a filter when prompted to select an image. You can add to or change the filter as desired. Also, you'll notice that the code exits the sub when the user is prompted to select an image, and clicks on Cancel.

Hope this helps!

 

[Spaztic]

I have amended your code as follows...

Sub InsertPic()

    Dim fNameAndPath As Variant
    Dim rng As Range
    Dim img As Picture
 
    fNameAndPath = Application.GetOpenFilename( _
        FileFilter:="Image Files (*.gif;*.jpg;*.png), *.gif;*.jpg;*.png", _
        Title:="Select an Image", _
        ButtonText:="Select")
     
    If fNameAndPath = False Then Exit Sub
 
    Set rng = ActiveCell
 
    Set img = ActiveSheet.Pictures.Insert(fNameAndPath)
    With img
        If .Width > .Height Then
            .Width = rng.Width * 0.8
        Else
            .Height = rng.Height * 0.8
        End If
        .Left = rng.Left + (rng.Width - .Width) / 2
        .Top = rng.Top + (rng.Height - .Height) / 2
       .Placement = 1
       .PrintObject = True
    End With
 
End Sub

You'll notice that I have added a filter when prompted to select an image. You can add to or change the filter as desired. Also, you'll notice that the code exits the sub when the user is prompted to select an image, and clicks on Cancel.

Hope this helps!

Amazing! Thank you so much! This was exactly what I was looking for and worked perfectly.

 

[Domenic]

That's great, I'm glad I could help.

Cheers!