Find if range has pictures [Solved with ongoing improvements?]

[Jagodragon]

I have to find if each cell in a range has a picture in it. 

I have the script below running in VB and need to figure out how to make it work for a range of cells.

Function HASpic(Cell As Range) As Boolean

'  Yields TRUE if the cell identified by row and col contains a picture,
'  otherwise FALSE

   Dim Caddress      As String
   Dim Pict          As Object
   
   Application.Volatile
   Caddress = Cell.Address
   
   For Each Pict In Application.Caller.Parent.Pictures
      If Pict.TopLeftCell.Address = Caddress Then
         HASpic = True
         Exit Function
      End If
   Next Pict
   HASpic = False
   
End Function

The code works great but I need it to cycle through all of the cells in a dynamic range. some thing like the pic below.

I tried using the code below to call to the first script, but that didn't work. any suggestion?

Sub HASpicR(x As Range)

'  Yields TRUE if the cell identified by row and col contains a picture,
'  otherwise FALSE

   Dim Caddress      As String
   Dim Pict          As Object
   
   For Each Cell In x
      HASpic (Cell)
   Next Cell
   
End Sub

Solution:

Edit HASpic function to accept a string for the cell address and run it using a BYROW formula.

Formula:

=BYROW(B4#,LAMBDA(array,HASpic(ADDRESS(ROW(array),COLUMN(array)))))

Function:

Function HASpic(Caddress As String) As Boolean

'  Yields TRUE if the cell identified by row and col contains a picture,
'  otherwise FALSE

   Dim Pict          As Object
   
   Application.Volatile
   For Each Pict In Application.Caller.Parent.Pictures
      If Pict.TopLeftCell.Address = Caddress Then
         HASpic = True
         Exit Function
      End If
   Next Pict
   HASpic = False
   
End Function

This is probably not the most elegant solution. But! It works... So, I'll take it!

[#2]

@mtarler  Sir  I need help, I have the same issue, but instead of pictures, I need the code for embedded objects (Excel spread sheets, PowerPoint, word documents) is that possible. instead of the Picture funcition, I used Shapes. unfortunately, it did not work. 

Function HASpicR(x As Range) As Variant

' Yields TRUE if the cell identified by row and col contains a picture,
' otherwise FALSE
Application.Volatile

Dim sourceCell, spillRange, p As Range
Dim r, c As Long
Dim s() As Variant

r = x.Rows.Count
c = x.Columns.Count
ReDim s(1 To r, 1 To c)

For Each Pict In ActiveSheet.Shapes
Set p = Pict.TopLeftCell
If Intersect(p, x).Count Then
s(p.Row - x.Row + 1, p.Column - x.Column + 1) = True
End If
Next Pict
HASpicR = s

End Function

[#3]

In theory I'm sure there is a way but not sure and wasn't even able to paste a word object into a spreadsheet. can you share an example? the other property you might try is .ListObjects
I would in the immediate pane just do a quick
Print activesheet.ListObjects.count
as a way to see if it might be a candidate for what you need. I still would have guessed Shapes. Maybe do the same 'count' test with Shapes and maybe the problem is what properties within the Shape Object are valid for that type.

[#4]

@mtarler  

Thank you, sir, for your respond.  Basically, I am doing a sheet where employees can attach their excel document in a cell. I don't want to open each document to check if the employees have submitted or not. My aim is when i well open my dashboard or report to see if it is attached or not as you did in the picture example, return true if there is attachment or false if the cell is empty. I will upload my design to make it easier. 

[#5]

@mtarler 

sir I have tried the list Object. I think its reading, but it is not counting. I will post the code plus a photo.

Function HASpicR(x As Range) As Variant

' Yields TRUE if the cell identified by row and col contains a picture,
' otherwise FALSE
Application.Volatile
'Dim Pict As Object
Dim sourceCell, spillRange, p As Range
Dim r, c As Long
Dim s() As Variant

r = x.Rows.Count
c = x.Columns.Count
ReDim s(1 To r, 1 To c)
'Dim Pict As Object
For Each Pict In ActiveSheet.ListObjects

Set p = Pict.TopLeftCell
If Intersect(p, x).Count Then
s(p.Row - x.Row + 1, p.Column - x.Column + 1) = True
End If
Next Pict
HASpicR = s

End Function

[#6]

@mtarler 

I have fix it sir. Instead of Listobjects, I have used OLEObjects

please see the photo.

[#7]

great. glad you got it working. best of luck with the project.

[#8]

Thank you Sir. Have a Nice Day