Allow users to browse for and insert picture

moogeedoo2

New Member
Joined
May 23, 2016
Messages
5
dear excel masters
Greetings,,,
I made a form in an excel sheet and request from users to fill it. this form have a cell for the user photo and what I need exactly is let the user when click on this cell open the file dialog to browse his photo and select it, after that I want it to show in the cell as per the cell dimensions. Please help me and if any inquiry I am here to answer your inquiries and kindly excuse me in any Linguistic mistake
Thank you for your permanent support
 
Hello, moogeedoo2,

The following is the code I use to insert a picture into a cell. (It doesn't entirely fit what you are looking for, some parts are specific for my use only, such as Path_Prefix. My setup is A1 must contain the word "Picture" and B1 "Item No". B2 and below contains the name of the file, well, name of the file minus ".jpg".) You can modify it to suit your need.

The first part of your question - click a cell to open a dialog box for user to select a picture file to insert- should be easy although I have not done it before.

Code:
Sub Insert_Picture_new()
'take item number in Name_Column, insert corresponding picture in Picture_Column

Const Sheet_to_Insert_Picture = 1
Const Name_Column = 2 'column that holds the name of the picture file
Const Picture_Column = 1 'column that holds pictures
Const factor = 0.9  'picture is 90% of the size of cell
Dim p As Object
Dim Top_Offset As Integer   'offset of picture top
Dim Last_Row As Integer 'last row in thisworkbook.sheets(sheet_to_insert_picture)
Dim rng As Range    'range of the cells to add pictures to
Dim cell As Range
Dim Path_Prefix As String
Dim Starting_Row As Integer
Dim Picture_NOT_Found As Integer    'number of items that has no picture

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.DisplayStatusBar = False

ActiveSheet.Pictures.Delete
Picture_NOT_Found = 0

'one way to find the last row
Last_Row = ActiveSheet.Cells(5000, 2).End(xlUp).Row

'set Path_Prefix
Path_Prefix = "D:\PICTURE DATABASE\"

'look for the first row to start insertion
Starting_Row = ActiveSheet.Range("A1:Z35").Find(what:="PICTURE", LookIn:=xlValues, lookat:=xlWhole, MatchCase:=False).Row + 1

If Len(Range("B" & Starting_Row + 1)) = 0 Then
Starting_Row = ActiveSheet.Cells(Starting_Row - 1, Name_Column).End(xlDown).Row
End If

'set the range of the cells that need insertion of picture
Set rng = ActiveSheet.Range(ActiveSheet.Cells(Starting_Row, Name_Column), ActiveSheet.Cells(5000, Name_Column).End(xlUp))

'if file fount, insert picture
If Len(Dir(Path_Prefix & Group_Code & "\" & Replace(cell.Value, "/", "-") & ".jpg")) <> 0 Then
'insert picture
Set p = Workbooks(ActiveSheet.Parent.Name).Sheets(ActiveSheet.Name).Shapes.AddPicture(Filename:=Path_Prefix & Group_Code & "\" & _
Replace(cell.Value, "/", "-") & ".jpg", LinkToFile:=False, SaveWithDocument:=True, Left:=ActiveSheet.Cells(cell.Row, Picture_Column).Left, _
Top:=ActiveSheet.Cells(cell.Row, Picture_Column).Top, Width:=-1, Height:=-1)

'set picture width (and height, which is automatically done because the aspect ratio is preserved)
p.Width = ActiveSheet.Cells(cell.Row, Picture_Column).Width * factor
'set picture position
p.Left = ActiveSheet.Cells(cell.Row, Picture_Column).Left + (ActiveSheet.Cells(cell.Row, Picture_Column).Width - p.Width) / 2
p.Top = ActiveSheet.Cells(cell.Row, Picture_Column).Top + (ActiveSheet.Cells(cell.Row, Picture_Column).Height - p.Height) / 2

Else
'highlight cell with a color
cell.Interior.Color = 65535
'increment count of Picture not found
Picture_NOT_Found = Picture_NOT_Found + 1
End If

Next

Application.DisplayStatusBar = True
Application.Calculation = xlCalculationAutomatic
Application.DisplayAlerts = True

If Picture_NOT_Found <> 0 Then
'display number of pictures not found
MsgBox (Picture_NOT_Found & " pictures not found.")
End If

Set p = Nothing

End Sub
 
Last edited:
Upvote 0

Excel Facts

Links? Where??
If Excel says you have links but you can't find them, go to Formulas, Name Manager. Look for old links to dead workbooks & delete.

Forum statistics

Threads
1,213,531
Messages
6,114,167
Members
448,554
Latest member
Gleisner2

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top