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]

It doesn't work because it doesn't loop through the range or because you haven't assigned the T/F to anything? I would have expected something like:
HASpicR = FALSE
For Each Cell In x
HASpicR = HASpicR OR HASpic (Cell))
Next Cell

EDIT: and noticed that HASpicR would also need to be a FUNCTION of boolean type like the original HASpic function

[#3]

Thank you. It is looping now. but it is still only giving me one value. it is not populating a range.

[#4]

This didn't get me there. but thank you. I'm Editing the main post to contain the solution right now.

[#5]

@Jagodragon 

Option Explicit


Public Function IsOne(val As Variant) As Boolean

IsOne = False

If val = 1 Then
    IsOne = True
End If


End Function


Public Function IsOneRange(rng As Range) As Variant

Dim output() As Boolean
Dim i As Integer

ReDim output(1 To rng.Rows.Count)

For i = 1 To rng.Rows.Count
    output(i) = IsOne(rng.Cells(i, 1))
Next i

IsOneRange = Application.WorksheetFunction.Transpose(output)

End Function

To return an array, you must build it in the function. My example above uses a simple "IsOne" instead of "HasPic", but I think you will see the idea. 

Let me know if it works.

[#6]

@flexyourdata This worked great when combined with the change to make HASpic accept the an address(see edit in main post)! THANK YOU! 

Function HASpicR(x As Range) As Variant

   Dim output()
   Dim i As Integer
      
   ReDim output(1 To x.Rows.Count)
   
   For i = 1 To x.Rows.Count
      output(i) = HASpic(x.Cells(i, 1).Address)
   Next i
   
   HASpicR = Application.WorksheetFunction.Transpose(output)
   
End Function

[#7]

@Jagodragon  I see you already have your solution but I will submit this because your solution has a few drawbacks.  a) it is only for a single column  b) it is looping through every picture for every cell in the range you are interested in.  so if you have 100 pictures over 300 lines that means 30,000 checks.  I reworked the original function to assign a TRUE value if it is in the range.  I didn't initialize the whole array to FALSE so the output is 0 or True instead of T/F.  But it only loops the pictures 1x and can handle multiple columns.

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 Application.Caller.Parent.Pictures
      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

I'm guessing you don't need it but since I did it (more for my own satisfaction) i thought I would post it.

[#8]

This looks awesome! I will see if I can implement it. I actually had to rework the solution already to allow it to work on a different tab from the source array. So I have to do the same thing here. I'll let you know what I find.

[#9]

I get a #value error when I use this code. it has no range output. Am I missing something?

What are the sourceCell, spillRange and p variables used for?

[#10]

@Jagodragon See attached.  This is what it should look like:

sourceCell and spillRange are left over from something else I was trying and never deleted.

p temporarily holds the top left cell of the picture object as it loops through them.

I didn't do extensive testing so try the attached sheet first and then we can see what is different in your sheet.

[#11]

I copy pasted from your workbook to mine and it still gives the same result... I'm at a loss... It works fine in the file you sent... what could be causing this?

[#12]

Can you send me a copy of the file?
Are there other objects in the file? I don't know if or why they might be a problem but maybe.

[#13]

@mtarler  I replicated the issue in your file to try and debug. your file was much simpler than the one i'm actually working in. Here's what i found.

If there are any pictures outside of the selection area ["=HASpicR(A3:B12)" in your excel file.] then the function fails. I had to add a check if p.Address fell in the range before it got to "If Intersect.."

perhaps there is a better way and I'm just not seeing it? Also, I changed it to output the picture name.

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 Cell In x
      'MsgBox (Cell.Address)
   Next Cell
   
   For Each pict In Application.Caller.Parent.Pictures
      Set p = pict.TopLeftCell
      For Each Cell In x
         If p.Address = Cell.Address Then
            If Intersect(p, x).Count Then
               'MsgBox ("Works: " & p.Address & "")
               s(p.Row - x.Row + 1, p.Column - x.Column + 1) = pict.Name
            End If
         End If
      Next Cell
   Next pict
   HASpicR = s
   
End Function

[#14]

@Jagodragon sry that was a rookie mistake. lol.  here is the corrected code:

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 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 Application.Caller.Parent.Pictures
      Set p = Pict.TopLeftCell
      If Not Intersect(p, x) Is Nothing Then
         s(p.Row - x.Row + 1, p.Column - x.Column + 1) = True
      End If
   Next Pict
   HASpicR = s
   
End Function

basically made this change:

If Not Intersect(p, x) Is Nothing Then

instead of  If Intersect(p, x).count Then

[#15]

Well, this is now the best response. But, I don't know how to change that flag..

[#16]

You can go to the ... of the message and select not best response and then select new but that's ok, I appreciate the "Likes" just as well and knowing that it was helpful :)

[#17]

DONE! thank you

[#18]

@mtarler 

I actually need this to work across worksheets so I've made a slight change. this works (and I'm happy with it), but I would rather not have to include the SHT string as an optional variable.

also, I just thought i would share incase some one else had the same need.

Function HASpicR(x As Range, Optional SHT As String = "") As Variant

'  Yields TRUE if the cell identified by row and col contains a picture,
'  otherwise FALSE
    Application.Volatile
    
   Dim 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)
   
   If SHT = "" Then
      For Each Pict In Application.Caller.Parent.Pictures
         Set p = Pict.TopLeftCell
         If Not Intersect(p, x) Is Nothing Then
            s(p.Row - x.Row + 1, p.Column - x.Column + 1) = True
         End If
      Next Pict
   Else
      For Each Pict In Worksheets(SHT).Shapes
         Set p = Pict.TopLeftCell
         If Not Intersect(p, x) Is Nothing Then
            s(p.Row - x.Row + 1, p.Column - x.Column + 1) = True
         End If
      Next Pict
   End If
   
   HASpicR = s
   
End Function

[#19 · Accepted solution]

@Jagodragon good point.  this should address that issue (i.e. search for pictures on the same sheet as the range your select)

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 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 x.Parent.Pictures
      Set p = Pict.TopLeftCell
      If Not Intersect(p, x) Is Nothing Then
         s(p.Row - x.Row + 1, p.Column - x.Column + 1) = True
      End If
   Next Pict
   HASpicR = s
   
End Function

[#20]

Really? It's that simple? OMG I'm such a newb... Thank you!