Macro to insert picture into a cell

[__Steve__]

Hi Excel Gurus

I am working on a macro allowing me to insert a picture into a cell activated with a button. I'd like to find out how this could be done. After clicking on a button "Insert Drawing" a generic windows dialog box should pop up asking me to select a picture I'd like to insert. After selecting required picture it would be inserted into a cell with resizing option to match cell width but locked aspect ration (cell height would adjust to keep original aspect ratio). Inserted picture need to be moving and scaling with cells. Please help

 

[patel45]

an example to start

Private Sub AddLogo_Click()
Set Rng = Selection
fName = Application.GetOpenFilename("Picture files (*.jpg;*.gif;*.bmp), *.jpgs;*.gif;*.bmp", , _
            "Select the picture")
If fName = "False" Then Exit Sub
ActiveSheet.Pictures.Insert(fName).Select
     With Selection.ShapeRange
        .LockAspectRatio = msoFalse
        .Top = Rng.Top
        .Left = Rng.Left
        Rng.Select
    End With
End Sub

 

[__Steve__]

Thank you Patel45, it's a good start. I have modified the code a bit as I want the picture to maintain original aspect ratio and want to be able to insert tif files as well.

Private Sub Insert_Pic1()
Set rng = Selection
fName = Application.GetOpenFilename("Picture files (*.jpg;*.gif;*.bmp;*.tif), *.jpgs;*.gif;*.bmp;*.tif", , _
"Select the picture")
If fName = "False" Then Exit Sub
ActiveSheet.Pictures.Insert(fName).Select
With Selection.ShapeRange
.LockAspectRatio = msoTrue
.Top = rng.Top
.Left = rng.Left
rng.Select
End With
End Sub

Now, can I specify cell B15 to insert a picture into instead of selection?

 

[__Steve__]

Ok, I've changed the code so that it inserts a picture into cell B15. Now I have problems with resizing the picture - it's nearly there, just needs to be brushed up

I get an error in this line:

.ShapeRange.LockAspectRatio = msoTrue

Here's the code:

Private Sub Insert_Pic1()
Set rng = ActiveSheet.Range("B17")
fName = Application.GetOpenFilename("Picture files (*.jpg;*.gif;*.bmp;*.tif), *.jpgs;*.gif;*.bmp;*.tif", , _
"Select picture to insert")
If fName = "False" Then Exit Sub
ActiveSheet.Pictures.Insert(fName).Select
With Selection.ShapeRange
.ShapeRange.LockAspectRatio = msoTrue
.Height = ActiveCell.Height
.Width = ActiveCell.Width
.Top = ActiveCell.Top
.Left = ActiveCell.Left
.Placement = xlMoveAndSize

End With
End Sub

 

[Useful]

Ok, I've changed the code so that it inserts a picture into cell B15. Now I have problems with resizing the picture - it's nearly there, just needs to be brushed up

I get an error in this line:

.ShapeRange.LockAspectRatio = msoTrue

Reason of your error message is - u needn't to use ".ShapeRange" part again when running With End with

 

[__Steve__]

Ok, I removed the ".Shape.Range" suffix and it is working, but when I select other cell it still inserts a picture into selected cell instead of cell B17. Also how can I specify the inserted picture to resize to match cell size with keeping aspect ratio? I also need to to move and size with cells.

My recent code is:

Private Sub Insert_Pic1()
Set rng = ActiveSheet.Range("B17")
fName = Application.GetOpenFilename("Picture files (*.jpg;*.gif;*.bmp;*.tif), *.jpgs;*.gif;*.bmp;*.tif", , _
"Select picture to insert")
If fName = "False" Then Exit Sub
ActiveSheet.Pictures.Insert(fName).Select
With Selection.ShapeRange
.LockAspectRatio = msoTrue
.Width = 815
.Top = ActiveCell.Top
.Left = ActiveCell.Left

End With
End Sub

 

[Useful]

(worksheet event code)

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$B$17" Then
'your code here
End if

 

[__Steve__]

So the code specifies that it will insert a picture only if B17 is selected? It doesn't work or I don't know how to use it...

 

[Useful]

So the code specifies that it will insert a picture only if B17 is selected? It doesn't work or I don't know how to use it...

try this
(in this case code will run when B17 is selected)

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Address = "$B$17" Then
fName = Application.GetOpenFilename("Picture files (*.jpg;*.gif;*.bmp;*.tif), *.jpgs;*.gif;*.bmp;*.tif", , _
"Select picture to insert")
If fName = "False" Then Exit Sub
ActiveSheet.Pictures.Insert(fName).Select
With Selection.ShapeRange
.LockAspectRatio = msoFalse
.Height = ActiveCell.Height
.Width = ActiveCell.Width
.Top = ActiveCell.Top
.Left = ActiveCell.Left
End With
End If
End Sub

 

[__Steve__]

Is it possible to execute the macro without selecting the B17 cell?; i.e. macro would insert a picture in cell B17 regardless of what cell is selected