Forum Discussion

Iron Contributor

May 24, 2022

Solved

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

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

excel

Formulas and Functions

mtarler

May 27, 2022

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

Jagodragon

Iron Contributor

May 26, 2022

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

mtarler

Silver Contributor

May 26, 2022

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

Jagodragon
Iron Contributor
May 27, 2022
Really? It's that simple? OMG I'm such a newb... Thank you!

mtarler

Silver Contributor

May 27, 2022

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

Jagodragon

Iron Contributor

May 27, 2022

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

Jagodragon
Iron Contributor
May 27, 2022
DONE! thank you
mtarler
Silver Contributor
May 27, 2022
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 🙂
Jagodragon
Iron Contributor
May 27, 2022
Well, this is now the best response. But, I don't know how to change that flag..