Automatically Insert photos

Hi

First day on this forum, be gentle.

I have a problem that is driving me mental, I can get part of this done but the last bit is just elluding me.

I will try to explain the problem as fully as I can.

I have a process set up from an Access database that does quite a bit of preparation of data then finally sends the prepared data to an Excel spreadsheet. Click of a button spews the data out to Excel, prompts the user to choose a folder where to save the file then opens the resulting spreadsheet. So far so good.

The final bit of 'data' that needs to go into this sheet is a photo. As the spreadsheet is saved in the same folder as the photos I can get the path to the photo from using 'Application.ActiveWorkbook.Path'. I also know the filename of each photo, this is part of the dataload, so I can now get the full path to the photo (if necessary). Obviously I can get the VBA to open the file picker at the correct folder. It's the final bit I just can't get, getting it to choose the photo based on the filename and insert into the selected cell in my spreadsheet. When I can do that I can then code in the remainder of the function (which will scroll down 5 rows to the next cell where a photo is required, check if that has a photo filename in it, and if so do the same process again, and so on) I can do that bit.

I have tried several different solutions, none do exactly what I want. I can return the filename to the 'File Name' field, but that doesn't select the folder it is in. I can return the path to the 'File Name' field, but that doesn't select the photo, and using the full path including the filename returns an error. It seems this should be easy, but I just can't get it to select the photo and put it into my cell.

This is what I have so far, this does everything I want except selecting and the photo and entering it into the spreadsheet automatically:

Sub InsertPictures()
'Update 20140513
Dim PicList() As Variant
Dim PicFormat As String
Dim Rng As Range
Dim sShape As Shape
Dim FP As String
Dim F As String
Dim intChoice As Integer
Dim FPF As String

'return the current path to this spreadsheet as part of the initial path lookup
FP = Application.ActiveWorkbook.Path

'Now find the filename we want from the cell in question (select the sheet and cell and return the value)
F = Worksheets("qryMandB_WithACMs_").Range("A2").Value
'put the 2 together, this will be the initial filename
FPF = FP & "/" & F

With Application.FileDialog(msoFileDialogOpen)
.InitialFileName = FP

            On Error Resume Next
            PicList = Application.GetOpenFilename(PicFormat, MultiSelect:=True)
            xColIndex = Application.ActiveCell.Column
            If IsArray(PicList) Then
            xRowIndex = Application.ActiveCell.Row
            For lLoop = LBound(PicList) To UBound(PicList)
            Set Rng = Cells(xRowIndex, xColIndex)
            Set sShape = ActiveSheet.Shapes.AddPicture(PicList(lLoop), msoFalse, msoCTrue, Rng.Left, Rng.Top, Rng.Width, Rng.Height)
            xRowIndex = xRowIndex + 1
            Next
            End If
            
   ' End If
End With
End Sub

I need this to be fully automated if possible. So, is it possible? Or am I going about this the wrong way? Any help greatly appreciated, thanks.

It's OK guys, I was doing it the wrong way. This works an absolute treat. I put into the on open event of my sprteadsheet and hey presto:
Dim cCell As Range
Dim FP As String
Dim F As String
Dim intChoice As Integer
Dim FPF As String

'check if 'Photos Prepared' is entered into the cell, of so do not run the macro, if not then run it
'
Sheets("ACM Summary").Select
Sheets("Lookup").Visible = True

If Sheets("Lookup").Range("E2").Value = "Photos Prepared" Then
'do nothing
' Hide the input sheets
Sheets("Lookup").Activate
ActiveWindow.SelectedSheets.Visible = False

Else
'return the current path to this spreadsheet as part of the initial path lookup
FP = Application.ActiveWorkbook.path
'place this value into cells on the 2 query worksheets as it is required as part of the filenames for the photos
Sheets("Lookup").Select
Range("A2").Select
ActiveCell.FormulaR1C1 = FP

'go back to the default sheet for the next part

'select all the cells which are to contain photographs

Sheets("ACM Summary").Select

Union(Range( _
"A184,A189,A195,A201,A206,A212,A218,A223,A229,A235,A240,A246,A252,A257,A263,A269,A274,A280,A286,A291,A297,A303,A308,A314,A320,A325,A331,A337,A342,A348,A354,A359" _
), Range( _
"A365,A371,A376,A382,A388,A393,A399,A405,A410,A416,A422,A427,A433,A439,A444,A450,A456,A461,A467,A473,A478,A484,A490,A495,A501,A507,A512,A518,A524,A529,A535,A541" _
), Range( _
"A546,A552,A558,A563,A569,A575,A7,A13,A19,A25,A31,A36,A42,A48,A53,A59,A65,A70,A76,A82,A87,A93,A99,A104,A110,A116,A121,A127,A133,A138,A144" _
), Range("A150,A155,A161,A167,A172,A178")).Select
'now enter all the photos for the selected range, which is based upon the filename

For Each cCell In Selection
If cCell.Value <> "" Then
On Error Resume Next
ActiveSheet.Shapes.AddPicture _
filename:=cCell.Value, LinkToFile:=msoFalse, _
SaveWithDocument:=msoTrue, _
Left:=cCell.Offset(ColumnOffset:=0).Left, Top:=cCell.Top, _
Width:=cCell.Width, Height:=cCell.Height
End If
Next cCell
'reselect the top cell so the user can start at the top
Range("A1").Select



'now the non asbestos sheet
Sheets("Non ACM Summary").Select

Union(Range( _
"A188,A193,A198,A203,A211,A216,A221,A226,A234,A239,A244,A249,A257,A262,A267,A272,A280,A285,A290,A295,A303,A308,A313,A318,A326,A331,A336,A341,A349,A354,A359,A364" _
), Range( _
"A372,A377,A382,A387,A395,A400,A405,A410,A418,A423,A428,A433,A441,A446,A451,A456,A464,A469,A474,A479,A487,A492,A497,A502,A502,A510,A515,A520,A525,A533,A538,A543" _
), Range( _
"A548,A556,A561,A566,A571,A579,A584,A589,A594,A602,A607,A612,A617,A625,A630,A635,A640,A648,A653,A658,A663,A671,A676,A681,A686,A694,A699,A704,A709,A717,A722,A727" _
), Range( _
"A732,A740,A745,A750,A755,A763,A768,A773,A778,A786,A791,A796,A801,A809,A814,A819,A824,A832,A837,A842,A847,A855,A860,A865,A870,A878,A883,A888,A893,A901,A906,A911" _
), Range( _
"A916,A924,A929,A934,A939,A947,A952,A957,A962,A970,A975,A980,A985,A993,A998,A1003,A1008,A1016,A1021,A1026,A1031,A1039,A1044,A1049,A1054,A1062,A1067,A1072,A1077,A1085,A1090,A1095" _
), Range( _
"A1100,A1108,A1113,A1118,A1123,A7,A12,A17,A22,A27,A32,A37,A42,A50,A55,A60,A65,A73,A78,A83,A88,A96,A101,A106,A111,A119,A124,A129,A134,A142,A147,A152" _
), Range("A157,A165,A170,A175,A180")).Select
'now enter all the photos for the selected range, which is based upon the filename

For Each cCell In Selection
If cCell.Value <> "" Then
On Error Resume Next
ActiveSheet.Shapes.AddPicture _
filename:=cCell.Value, LinkToFile:=msoFalse, _
SaveWithDocument:=msoTrue, _
Left:=cCell.Offset(ColumnOffset:=0).Left, Top:=cCell.Top, _
Width:=cCell.Width, Height:=cCell.Height
End If
Next cCell
'reselect the top cell so the user can start at the top
Range("A1").Select
'



'insert Photos prepared into the lookup cell so that the if statement that stops this code from running every time knows that the spreadsheet is already prepared
Sheets("Lookup").Select
Range("E2").Select
ActiveCell.FormulaR1C1 = "Photos Prepared"
Sheets("ACM Summary").Select

' Hide the input sheet
Sheets("Lookup").Activate
ActiveWindow.SelectedSheets.Visible = False


Sheets("ACM Summary").Select
End If ' end of the if statement that checks if Photos Prepared has been entered