INSERTING MULTIPLE PICTURES THAT MEET CRITERIA

Hi

I am trying to insert pictures of candidates by checking their id number. If the id number (in sheet2 column B) matches with the filename in the directory of photos, then that candidates picture from the file location is inserted in a specific cell. The candidate list can vary in length.

I can insert the picture of ONE candidate by pointing to the exact location - that's not a problem.

However I am trying to loop through the id numbers on sheet2 and have become unstuck. I have tried various things and got some help (thanks TG) but still getting errors. Due to trying various things my code does look a bit funky right now - so apologies(!)

Also when the pictures are placed in the cell (starting at cell A12 Sheet1), then I need to fix the picture in the centre of the cell at fixed dimensions so that if there are lots of pictures, there's uniformity)

Can anybody help? File attached and thanks in advance.

Forgot to mention one additional issue if anyone can help.

The images are generally named by the candidate id number for e.g. '089721' or '000781'

However if the number begins with '0' or more than one zero, Excel ignores them ... so '089721' becomes 89721 etc. When trying to match the photo id numbers with column b on sheet 2 this will no doubt throw up an error or 'no match found'? Wondering whether I would have to use the trim function? to ignore any zeros at the beginning of the photo filenames?

Would greatly appreciate if anyone can help as I think I'm nearly there. :doh:

Ok think I have made some progress. I have gone back to basics to get a working version .... after which I am hoping I can match the photos with the id in Column B on sheet2.

I have attached my file again with some jpegs so you can test it. Could somebody take a look?

If your pic filenames are always formatted to six digits, you can use Format() to get a match to just integer values. e.g.

Code:

---

Sub Test() 
  Dim i As Integer
  i = 1234
  MsgBox Format(i, "000000")
End Sub

---

Of course your columns with the base pic filenames could be formatted. The code would then look at the cell's Text property rather than the default Value property. One can also go the other way and get a numeric value from a formatted string value. That strips out the leading 0's. Here are two ways.

Code:

---

Sub Test2() 
  Dim s As String, i As Integer
  s = "001234"
  MsgBox Val(s)
  i = s
  MsgBox i
End Sub

---

I am not sure what you wanted the macro to do. I see that you are working with 4 columns in your macro but I don't know why.

In the past, I helped people insert pics by a change in base filename. That way, it was always dynamic. Column A would have the base name and column B would contain the pic. The base name is matched to a named range like the range that you have setup in Sheet2.

If all you wanted was a one time delete all pics and then insert pics, that is a bit less code. I just have to study your code a bit more or maybe it was just a small test?

The last thing that I would do is the center pic part. To center both horizontal and vertical in a cell can be tricky. One has to consider proportions to know which governs if either governs. e.g. Case1: Ignoring units: wxh, pic is 1200x1600, this means that is portrait style so height governs. Case2: 30x29, landscape or width governs. In case1, we reduce height to 40 but keep proportion so width is proportionally reduced to less than 40. In case 2, we increase width to 40 and keep proportions set so that height will be less than 40.

Hi Ken

Essentially I have list of candiates on Sheet2 (the number of candiates can change)

On sheet1 I want the pics of all the candidates listed on sheet 2 by checking the ID in column B Sheet2 against the filenames in the filedirectory (because of leading zeros, filenames may not match). The pics are then inserted in a certain cell location on sheet 1.

I've attached my sheet again so you can see what I mean. The images however are not centred and are not the same size despite me adjusting the size in the code. Also the images shoule be appearing horizontally (ie. starting at B12, C12, D12, E12 and then B13, C13, D13, E13 etc.) rather than a long list of vertical pics. So 4 pics across and then a new line of pics underneath and so on.

I hope that makes sense and thanks for taking time out to look at this.

Pics start at row 1 or 2? Most start at row 2.

If you don't have a consistent file naming convention for leading 0's then one has to get all file names in the parent folder and use Test2() to find a match. If you have filenames like 001234.jpg and 1234A.jpg one has to do a bit more work as well.

Normally, I prefer ActiveSheet.Shapes.AddPicture() rather than ActiveSheet.Pictures.Insert() so that I can link or embed the pic.

Centering is the more tricky part. So, I probably won't get enough time until tonight to look at that in more detail. The tricky deal has to do with Excel's cell dimension units vs. a pic's dimension units.

Row 2.

The file names in the file directory don't contain letters ... just leading zeros. So e.g. 000798 in the file directory is 798 is listed in the excel sheet2 columnB.

If it helps all the pics are the same size .. 200 x 240 px. The ones I uploaded were just dummy ones to illustrate the point ... but I was under the impression that you could just resize to whatever size and fix the position to cell centre. I would probably want them 50% of the size that they are to make it more manageable in Excel.

Also when you get a chance to see the file you'll notice that the filename itself (as well as the pic) appears with the pic covering the filename when the macro is run. It may be better for the filename to appear underneath the pic so that it's clearer as to what the candidate number is and who the candidate is.

Thanks again

Here is a quick way to do one for a test. Add the WIA reference and set the value in fn for your jpg. You will see that at 20, the fitted and resized pic is small.

Code:

---

'WIA examples, https://docs.microsoft.com/en-us/windows-hardware/drivers/image/windows-image-acquisition-driversSub AddPic2()
  Dim fn$, c As Range, s As Shape, w As Single, h As Single, wS As Single
  'https://docs.microsoft.com/en-us/previous-versions/windows/desktop/wiaaut/-wiaaut-imagefile#properties
  'Dim Img as object  'Late Binding
  'Tools > References > Microsoft Windows Image Acquisition Library v2.0 > OK
  Dim img As ImageFile  'Early Binding
 
  fn = "C:\Users\ken\_Excel\Controls\Picture\CandidatePics\000947.jpg"


  Columns("A:D").ColumnWidth = 20
  Rows("1:4").RowHeight = 20
  Set c = [A1]

  'Get pic's hxw using WIA
  Set img = CreateObject("WIA.ImageFile")
  img.LoadFile fn
  h = img.Height  'pixels
  w = img.Width 'pixels
  'hxw=594x792. 30x40" inserted as 8.25/11" = 792/1056 pixels, All ratio h/w=0.75. 96 pixels/1"
  'Debug.Print h, w
  Set img = Nothing
 
  '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)
End Sub

---

Thanks.
Sorry how do I set add the WIA reference .. not familiar with WIA and getting an error "user defined-type not defined" here

Code:

---

  Dim img As ImageFile

---

. My files are all jpegs.

I adding my fn value to point to my pic.

Just checking that I am not doing anything to this?

Code:

---

  Set img = CreateObject("WIA.ImageFile")

---

The WIA reference is set in the VBE Tools menu as I showed in the comment. This is standard practice for early bound objects.

Code:

---

'Tools > References > Microsoft Windows Image Acquisition Library v2.0 > OK
  Dim Img As ImageFile  'Early Binding

---

I used late binding for WIA object in the 2nd routine.

Change the value for p below. It may still need some work for landscape governed pics. As discussed previously, it would need a tweak if files don't use the leading 0's to six places naming convention. The shapes where named using the base filename so click the image to see the name in top left. This is a bit cleaner than adding text into a cell with the pic.

Code:

---

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
    AddPicFNs 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 AddPicFNs(fn$, c As Range, Optional shapeName$ = "")
  Dim s As Shape, w As Single, h As Single, wS As Single
  'https://docs.microsoft.com/en-us/previous-versions/windows/desktop/wiaaut/-wiaaut-imagefile#properties
  Dim Img as object  'Late Binding
  'Tools > References > Microsoft Windows Image Acquisition Library v2.0 > OK
  'Dim Img As ImageFile  'Early Binding


  'Get pic's hxw using WIA
  Set Img = CreateObject("WIA.ImageFile")
  Img.LoadFile fn
  h = Img.Height  'pixels
  w = Img.Width 'pixels
  'hxw=594x792. 30x40" inserted as 8.25/11" = 792/1056 pixels, All ratio h/w=0.75. 96 pixels/1"
  'Debug.Print h, w
  Set Img = Nothing
 
  '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

---

Thanks Ken - will try it out.... but can't seem to see ''Tools > References > Microsoft Windows Image Acquisition Library v2.0' in my Excel ... would it need adding/installing? Or could it be called something else?

Getting a runtime error 429 "ActiveX component can't create object" but assuming that's due to the above?

Whether the object was dimmed using early binding or late binding, the object must be in your VBE's Tools > References. You can check manually, by looking for c:\windows\system32\wiaaut.dll. If there but not in your references, we can register it to put it there.

If you are using Excel 64 bit, it may not be available. It could be in C:\Windows\SysWOW64\wiaaut.dll in that case but I doubt it.

If the WIA object method becomes an issue, I can look at another method to get the image properties without opening the object. e.g. wxh in pixels: http://www.snb-vba.eu/VBA_Bestanden_en.html#L_1.80

Hi branston!
I did a simple example.
Unzip the attachments to the same directory and click the button named "8".

Quote:

---

Originally Posted by Kenneth Hobs

Whether the object was dimmed using early binding or late binding, the object must be in your VBE's Tools > References. You can check manually, by looking for c:\windows\system32\wiaaut.dll. If there but not in your references, we can register it to put it there.

If you are using Excel 64 bit, it may not be available. It could be in C:\Windows\SysWOW64\wiaaut.dll in that case but I doubt it.

If the WIA object method becomes an issue, I can look at another method to get the image properties without opening the object. e.g. wxh in pixels: http://www.snb-vba.eu/VBA_Bestanden_en.html#L_1.80

---

Thanks Ken.

Unfortunately at work those file directories are restricted access so I wouldn't be able to register the .dll

You should be able to register dlls already there. Win+R > RegSvr32 c:\windows\system32\wiaaut.dll > Enter key

Then check VBE > Tools > References

Here is the GetDetails() method to get file dimensions rather than WIA.

I would recommend that you consider changing the column width value. The scale in Excel is not the same for column widths vs. row heights.

Code:

---

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

---

Thanks Ken.

On the 'extracting-numbers-from-alphanumeric-strings' bit at the very end, any ideas why I would get a run-time error with a 'type mismatch'

Code:

---

  NumberPart = s

---

? I've gone through your code and everything seems ok to me.

I don't know. The GetDetailsOF() method returns a value for those items that is unknown to VBA and shows as a "?". For me, the routine stripped those characters.

Try adding a Debug.Print to put a run result into VBE's Immediate Window:

Code:

---

Function NumberPart(aString As String) As Double
Debug.Print aString

---

One might also be able to add a CStr() to coerce the input into a string. e.g.

Code:

---

h = NumberPart(CStr(.GetDetailsOf(.Items.Item(f), 179)))

---

If you are still having problems, you can try this 3rd solution. This old method of mine is a bit redundant and not as efficient. It should work ok though if you don't insert more than a few hundred pics. If you are ok with linked images, it can be modified to just use the pictures.insert method alone.

Code:

---

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\lenovo1\Dropbox\_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
    AddPics3 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 AddPics3(fn$, c As Range, Optional shapeName$ = "")
  Dim s As Shape, w, h, wS As Single, ss As Picture
  Dim p, f
  Set ss = Worksheets(c.Parent.Name).Pictures.Insert(fn)
  h = ss.Height
  w = ss.Width
  ss.Delete
 
  'AddPicture as shape, linked pic or not linked as in this use.
  wS = c.Height * w / h
  Set s = Worksheets(c.Parent.Name).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

---