Consulting

Results 1 to 19 of 19

Thread: INSERTING MULTIPLE PICTURES THAT MEET CRITERIA

  1. #1

    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.
    Attached Files Attached Files

  2. #2
    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.

  3. #3
    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?
    Attached Images Attached Images
    Attached Files Attached Files

  4. #4
    VBAX Guru Kenneth Hobs's Avatar
    Joined
    Nov 2005
    Location
    Tecumseh, OK
    Posts
    4,892
    Location
    If your pic filenames are always formatted to six digits, you can use Format() to get a match to just integer values. e.g.
    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.
    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.
    Last edited by Kenneth Hobs; 07-18-2019 at 07:32 AM.

  5. #5
    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.
    Attached Images Attached Images
    Attached Files Attached Files

  6. #6
    VBAX Guru Kenneth Hobs's Avatar
    Joined
    Nov 2005
    Location
    Tecumseh, OK
    Posts
    4,892
    Location
    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.

  7. #7
    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

  8. #8
    VBAX Guru Kenneth Hobs's Avatar
    Joined
    Nov 2005
    Location
    Tecumseh, OK
    Posts
    4,892
    Location
    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.

    '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

  9. #9
    Thanks.
    Sorry how do I set add the WIA reference .. not familiar with WIA and getting an error "user defined-type not defined" here
      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?
      Set img = CreateObject("WIA.ImageFile")




  10. #10
    VBAX Guru Kenneth Hobs's Avatar
    Joined
    Nov 2005
    Location
    Tecumseh, OK
    Posts
    4,892
    Location
    The WIA reference is set in the VBE Tools menu as I showed in the comment. This is standard practice for early bound objects.
    '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.
    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

  11. #11
    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?
    Last edited by branston; 07-18-2019 at 09:15 PM.

  12. #12
    VBAX Guru Kenneth Hobs's Avatar
    Joined
    Nov 2005
    Location
    Tecumseh, OK
    Posts
    4,892
    Location
    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
    Last edited by Kenneth Hobs; 07-18-2019 at 10:00 PM.

  13. #13
    VBAX Mentor 大灰狼1976's Avatar
    Joined
    Dec 2018
    Location
    SuZhou China
    Posts
    433
    Location
    Hi branston!
    I did a simple example.
    Unzip the attachments to the same directory and click the button named "8".
    Attached Files Attached Files

  14. #14
    Quote Originally Posted by Kenneth Hobs View Post
    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

  15. #15
    VBAX Guru Kenneth Hobs's Avatar
    Joined
    Nov 2005
    Location
    Tecumseh, OK
    Posts
    4,892
    Location
    You should be able to register dlls already there. Win+R > RegSvr32 c:\windows\system32\wiaaut.dll > Enter key

    Then check VBE > Tools > References

  16. #16
    VBAX Guru Kenneth Hobs's Avatar
    Joined
    Nov 2005
    Location
    Tecumseh, OK
    Posts
    4,892
    Location
    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.

    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

  17. #17
    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'
       NumberPart = s
    ? I've gone through your code and everything seems ok to me.

  18. #18
    VBAX Guru Kenneth Hobs's Avatar
    Joined
    Nov 2005
    Location
    Tecumseh, OK
    Posts
    4,892
    Location
    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:
    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.
     h = NumberPart(CStr(.GetDetailsOf(.Items.Item(f), 179)))

  19. #19
    VBAX Guru Kenneth Hobs's Avatar
    Joined
    Nov 2005
    Location
    Tecumseh, OK
    Posts
    4,892
    Location
    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.

    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

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •