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

 

[__Steve__]

I am trying to figure out how to add / delete picture into a comment with one button (at the moment I have two separate buttons to do it). So the way I'd like it to work is if there is no picture inserted - insert picture. Is there is a picture inserted into the cell - delete it. It's close but I need someone experienced with programming to help me out.

Here is my code:

Sub Insert_Delete_Pic1()
Dim rng As Range
Set rng = ActiveSheet.Range("D15")
If Not (rng.Comment Is Nothing) Then rng.Comment.Delete
Else
With Application.FileDialog(msoFileDialogFilePicker)
.AllowMultiSelect = False 'Only one file
.InitialFileName = CurDir 'directory to open the window
.Filters.CLEAR 'Cancel the filter
.Filters.Add Description:="Images", Extensions:="*.jpg, *.png, *.tif", Position:=1
.Title = "Choose image to insert"
Enf If
If .Show = -1 Then TheFile = .SelectedItems(1) Else TheFile = 0
End With
'No file selected
If TheFile = 0 Then
MsgBox ("No image selected")
Exit Sub
End If
rng.AddComment
rng.Comment.Visible = False
rng.Comment.Shape.LockAspectRatio = msoTrue
rng.Comment.Shape.Width = 300
rng.Comment.Shape.Fill.UserPicture TheFile
End Sub

 

[__Steve__]

Anyone?

 

[__Steve__]

Ok, I managed to find the solution - it was close and after some trial and error process I did it. It is set up to insert / delete a picture in cell D15. Thanks everyone for help. Here's the code if anyone needs to use it:

Sub Insert_Pic1()
Dim rng As Range
Set rng = ActiveSheet.Range("D15")
If Not (rng.Comment Is Nothing) Then
rng.Comment.Delete
MsgBox ("Image deleted")
Exit Sub
End If
With Application.FileDialog(msoFileDialogFilePicker)
.AllowMultiSelect = False 'Only one file
.InitialFileName = CurDir 'directory to open the window
.Filters.CLEAR 'Cancel the filter
.Filters.Add Description:="Images", Extensions:="*.jpg, *.png, *.tif", Position:=1
.Title = "Choose image to insert"

If .Show = -1 Then TheFile = .SelectedItems(1) Else TheFile = 0
End With
'No file selected
If TheFile = 0 Then
MsgBox ("No image selected")
Exit Sub
End If
rng.AddComment
rng.Comment.Visible = False
rng.Comment.Shape.LockAspectRatio = msoTrue
rng.Comment.Shape.Width = 400
rng.Comment.Shape.Fill.UserPicture TheFile
MsgBox ("Image inserted")
End Sub

 

[Carlie17]

Hi All,

I'm new to the forum scene, I've used the code offered previously offered (below)

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Address = "$B$2" 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


However, I need this code to apply more than just one cell. for example I'd like to be able to click on cell B2, B5, B8, B11, B14, D2, D5, D8, D11 & D14.

If anyone can help, i would really appreciate it.

 

[Useful]

Hi and welcome!

if you want to apply choosen picture to the selected cells then use this

Sub Apply_multy_cells()
Set sel = Selection
fName = Application.GetOpenFilename("Picture files (*.jpg;*.gif;*.bmp;*.tif), *.jpgs;*.gif;*.bmp;*.tif", , _
"Select picture to insert")
If fName = "False" Then Exit Sub
For Each sl In sel
Set pic = ActiveSheet.Pictures.Insert(fName)
With pic.ShapeRange
.LockAspectRatio = msoFalse
.Height = sl.Height
.Width = sl.Width
.Top = sl.Top
.Left = sl.Left
End With
Next
End Sub

or may be simply you want to run the code by clicking several cells then use or function
Target.Address = "$B$2" or Target.Address = "$B$5" or Target.Address = "$B$8" ... and so on

 

[dvorak]

Hello everyone,

I've used this code offered below, and I need some help to add two features if possible
Such as:

-Insert the pic name in a cell
-Create a link to a folder where this image followed by /picname.jpg

Is this possible?
Other thing is to use this in a range of cels
I've tried smething like
If Target = "$D$1:$D$10" Then

But don't works..

I would really appreciate some help.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Address = "$D$1" Or Target.Address = "$D$2" 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

Running the code below on a mac is getting error at the line fname.

In windows is working fine. Anyone confirm this?