This is a sample of some code I use to add a photo file to an Excel photo database. You may get started with some code of your own?
Excel renames photo objects so the code is not too easy to work with! JSW
Sub s_Photos()
'Adds a photo below the last photo if any.
Application.ScreenUpdating = False
Range("D65536").End(xlUp).Offset(4, -2).Select
ActiveCell.RowHeight = 118.5
ActiveCell.ColumnWidth = 32.43
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThick
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThick
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThick
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThick
.ColorIndex = xlAutomatic
End With
myFile = Application.InputBox("Enter your, ""Drive:PathFile.jpg"" for your Photo." _
& Chr(13) & Chr(13) & " Like, C:MyFilesJSWExcelFOREST03.JPG" & Chr(13) & Chr(13) _
& " In the box below!", Title:="Please indicate the photo location!" _
, Default:="C:MyFilesJSWExcelFOREST03.JPG")
On Error GoTo Kil
'ActiveSheet.Pictures.Insert("C:MyFilesJSWExcelFOREST03.JPG").Select
ActiveSheet.Pictures.Insert(myFile).Select
Selection.ShapeRange.ScaleHeight 0.34, msoFalse, msoScaleFromTopLeft
Selection.ShapeRange.ScaleWidth 0.33, msoFalse, msoScaleFromTopLeft
With Selection
.Placement = xlMoveAndSize
.PrintObject = True
End With
ActiveCell.Offset(0, 2).Select
Selection.Interior.ColorIndex = xlNone
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlTop
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.MergeCells = False
End With
ActiveCell.FormulaR1C1 = "Photo: "
With ActiveCell.Characters(Start:=1, Length:=8).Font
.Name = "Arial"
.FontStyle = "Regular"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
Range("A1").Select
Application.ScreenUpdating = True
Kil:
Range("A1").Select
Application.ScreenUpdating = True
End Sub