Excel 2003, how to get top left and bottom right of range?

Question

I have a range which I would like to check to see if any shapes are placed on it.

I found a script online (http://www.mrexcel.com/forum/excel-questions/317711-visual-basic-applications-identify-top-left-cell-selected-range.html), but it doesn't work for Excel 2003. The code I have so far which is adapated from the found script:

    Public Function removeOLEtypesOfType() As Boolean
        On Error Resume Next

        Dim objTopLeft As Range, objBotRight As Range _
          , objRange As Range, objShape As Shape
        Set objRange = Sheet1.Range(COLUMN_HEADINGS)
        objRange.Select

        With Selection
            Dim intFirstCol As Integer, intFirstRow As Integer _
              , intLastCol As Integer, intLastRow As Integer
            intFirstCol = .Column
            intFirstRow = .Row
            Set objTopLeft = .Cells(intFirstRow, intFirstCol) '.Address(0, 0)
            intLastCol = .Columns.Count + .Column - 1
            intLastRow = .Rows.Count + .Row - 1
            Set objBotRight = .Cells(intLastRow, intLastCol) '.Address(0, 0)

            If objTopLeft Is Nothing Or objBotRight Is Nothing Then
                MsgBox "Cannot get topleft or bottom right of range!", vbExclamation
                removeOLEtypesOfType = False
                Exit Function
            End If
            For Each objShape In ActiveSheet.Shapes
                Dim objTLis As Range
                Set objTLis = Intersect(objTopLeft, objShape.TopLeftCell)

                If Not objTLis Is Nothing Then
                    Dim objBRis As Range
                    Set objBRis = Intersect(objBotRight, objShape.BottomRightCell)

                    If Not objBRis Is Nothing Then
                        objShape.Delete
                    End If
                End If
            Next
        End With
        Sheet1.Cells(1, 1).Select
        removeOLEtypesOfType = True
    End Function

objTopLeft and objBotRight are both Nothing, COLUMN_HEADINGS contains the name of the range.

I've checked intFirstCol, intFirstRow, intLastCol and intLastRow in the debugger and they are correct.

Edit... With .Address commented out both both topleft and botright ranges are returned but with .Address in, both are Nothing. The ranges returned do not appear to be for the correct locations.

For example for the supplied range:

    intFirstCol = 3
    intFirstRow = 11
    intLastCol = 3
    intLastRow = 186

The above are correct, however:

    objTopLeft.Column = 5
    objTopLeft.Row = 21
    objBotRight.Column = 5
    objBotRight.Row = 196

Thee above are not correct, the Columns are +2 and the Rows are +10, why?

Answer 1

Fixed:

    Public Function removeOLEtypesOfType() As Boolean
        On Error Resume Next

        Dim objTopLeft As Range, objBotRight As Range _
          , objRange As Range, objShape As Shape
        Set objRange = Sheet1.Range(COLUMN_HEADINGS)
        objRange.Select

        With Selection
            Set objTopLeft = .Cells(1)
            Set objBotRight = .Cells(.Cells.Count)

            If objTopLeft Is Nothing Or objBotRight Is Nothing Then
                MsgBox "Cannot get topleft or bottom right of range!", vbExclamation
                removeOLEtypesOfType = False
                Exit Function
            End If
            For Each objShape In ActiveSheet.Shapes
                Dim blnTLcol As Boolean, blnTLrow As Boolean _
                  , blnBRcol As Boolean, blnBRrow As Boolean
                blnTLcol = (objShape.TopLeftCell.Column >= objTopLeft.Column)
                blnTLrow = (objShape.TopLeftCell.Row >= objTopLeft.Row)
                blnBRcol = (objShape.BottomRightCell.Column <= objBotRight.Column)
                blnBRrow = (objShape.BottomRightCell.Row <= objBotRight.Row)
                If blnTLcol = True And blnTLrow = True _
                And blnBRcol = True And blnBRrow = True Then
                    objShape.Delete
                End If
            Next
        End With
        Sheet1.Cells(1, 1).Select
        removeOLEtypesOfType = True
    End Function

Thanks @Ambie I simplified the routine, can't give you the answer as this wasn't the problem but has helped to clean up the code.

Answer 2

The easiest way to due this is to create a range from the Shape.TopLeftCell to it's Shape.BottomRightCell and then test to see if the two ranges intersect.

Set rShageRange = Range(objShape.TopLeftCell, objShape.BottomRightCell)

Sub FindShapesInRange()
    Dim objShape As Shape
    Dim rSearch As Range, rShageRange As Range

    Set rSearch = Range(COLUMN_HEADINGS)

    For Each sh In ActiveSheet.Shapes

        Set rShageRange = Range(objShape.TopLeftCell, objShape.BottomRightCell)

        If Not Intersect(sh.TopLeftCell, rSearch) Is Nothing Then

            Debug.Print "Shape Name: " & objShape.Name & " Shape Range: " & rShageRange.Address

        End If

    Next

End Sub

Answer 3

That seems a complicated way of getting top left and bottom right, and your code won't work if your selection includes non-contiguous cells. The code below might be more suitable:

With Selection
    Set objTopLeft = .Cells(1)
    Set objBottomRight = .Cells(.Cells.Count)
End With