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