Sub Main()
Dim fn$, m$, p$, s As Shape, r As Range, c As Range
Dim pR As Range, cc As Range, fso As Object
Dim ws1 As Worksheet
'Folder with candidate jpg's
p = "C:\Users\ken\_Excel\Controls\Picture\CandidatePics\"
Set ws1 = Worksheets(1)
'Range with candidate names to match.
Set r = ws1.Range("F1", Worksheets(1).Range("F1").End(xlDown))
'Range with candidate names and base filenames with no leading 0's.
Set pR = Worksheets(2).UsedRange
Set fso = CreateObject("Scripting.FileSystemObject")
ws1.Columns("A:D").ColumnWidth = 20
ws1.Rows("1:" & WorksheetFunction.RoundUp(r.Cells.Count / 4, 0) + 1).RowHeight = 20
ws1.Pictures.Delete
Set cc = ws1.Range("A2")
On Error GoTo NextC
For Each c In r
'=VLOOKUP(F1,Sheet2!A1:B11,2,FALSE)
m = WorksheetFunction.VLookup(c, pR, 2, False)
fn = p & Format(m, "000000") & ".jpg"
If Dir(fn) = "" Then GoTo NextC
AddPics fn, cc, Format(m, "000000")
NextC:
'Set next cell to add pic or not.
Set cc = cc.Offset(, 1)
'Move to next cell row column A if cc.column is more than 4.
If cc.Column > 4 Then Set cc = ws1.Cells(cc.Row + 1, "A")
Next c
End Sub
Sub AddPics(fn$, c As Range, Optional shapeName$ = "")
Dim s As Shape, w, h, wS As Single
Dim fso As Object, p, f
Set fso = CreateObject("Scripting.FileSystemObject")
p = fso.GetParentFolderName(fn) & "\"
f = fso.GetFileName(fn)
'Get pic's hxw in pixels using GetDetailsOf()
'31 = ?80 x 118?, 177 is width item = ?80 pixels, 179 is height item = ?118 pixels
With CreateObject("Shell.Application").Namespace(p)
h = NumberPart(.GetDetailsOf(.Items.Item(f), 179))
w = NumberPart(.GetDetailsOf(.Items.Item(f), 177))
End With
'hxw=594x792. 30x40" inserted as 8.25/11" = 792/1056 pixels, All ratio h/w=0.75. 96 pixels/1"
'AddPicture as shape, linked pic or not linked as in this use.
wS = c.Height * w / h
Set s = ActiveSheet.Shapes.AddPicture(fn, msoFalse, msoCTrue, c.Left + c.Width / 2 - wS / 2, c.Top, wS, c.Height)
If shapeName <> "" Then s.Name = shapeName
End Sub
' formula, http://office.microsoft.com/en-us/excel-help/extracting-numbers-from-alphanumeric-strings-HA001154901.aspx
' Modified by Kenneth Hobson
Function NumberPart(aString As String) As Double
Dim s As String, i As Integer, mc As String, mc2 As String
aString = Replace(aString, ",", "")
For i = 1 To Len(aString)
mc = Mid(aString, i, 1)
mc2 = ""
If i <> Len(aString) Then mc2 = Mid(aString, i + 1, 1)
If Not IsNumeric(mc2) Then mc2 = ""
If Asc(mc) >= 48 And Asc(mc) <= 57 _
Or (mc = "-" And mc2 <> "") _
Or (mc = "." And mc2 <> "") _
Then s = s & mc
Next i
NumberPart = s
End Function