Allow users to browse for and insert picture

[moogeedoo2]

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

 

[yky]

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.

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