Excel - VBA - Function detecting image in cell

Question

I wanted to write a function that detects if there is an Image in the cell. When not, it goes to the next row. The column stays the same.

My Function doesnt work.

Public Function HasImage(ByVal Target As Range) As Boolean
Dim bResult As Boolean
Dim shp As Shape
     bResult = False
         For Each shp In ActiveSheet.Shapes
             If shp.TopLeftCell.Address = Target.Address _
                     And shp.BottomRightCell.Address = Target.Address Then
                 bResult = True
             End If
         Next shp
     HasImage = bResult
 End Function

Answer 1

I may be wrong but does your BottomRightCell have to be offset (1,1) from the topleft when image sized to one cell?

In my testing your code seemed to fail because of the BottomRightCell.Address , with pic sized to one cell, being a row below and a column to the right.

I tested with the following code where I adjusted BottomRightCell.Addres s with:

And shp.BottomRightCell.Address = Target.Offset(1, 1).Address 

Code:

Option Explicit

Public Sub test()
    Dim mypic As Object

    Set mypic = ActiveSheet.Pictures(1)
    PositionPic mypic
    MsgBox HasImage([A1])
    MsgBox mypic.BottomRightCell.Address

End Sub

Public Function HasImage(ByVal Target As Range) As Boolean
    Dim bResult As Boolean
    Dim shp As Shape
    bResult = False
    For Each shp In ActiveSheet.Shapes
        If shp.TopLeftCell.Address = Target.Address _
           And shp.BottomRightCell.Address = Target.Offset(1, 1).Address Then
            bResult = True
        End If
    Next shp
    HasImage = bResult
End Function

Public Sub PositionPic(ByVal mypic As Object)
    With mypic
        .Left = ActiveSheet.Cells(1, 1).Left
        .Top = ActiveSheet.Cells(1, 1).Top
        .Width = ActiveSheet.Cells(1, 1).Width
        .Height = ActiveSheet.Cells(1, 1).Height
    End With
End Sub