Wipe off the Picture objects from Excel Sheet

Amjad.Mahmoood · September 7th, 2006, 12:13 AM

Sub wipeoff()
Do While ActiveSheet.Shapes.Count <> 0
ActiveSheet.Shapes(1).Delete
Loop
End Sub

The above macro clears all pictures/drawing objects from the active sheet.

Now my problem is that I wish to change this macro so that removal of shapes/picture objects is restricted to the user given selection only (not the entire sheet).

Please help.
Thank you in advance

maccas · September 7th, 2006, 03:16 AM

Amjad,

Its not clear whether you want to restrict the range of shape deletion to a pre-specified range or to user prompt shape-by-shape for deletion. In any case I've written a couple of macros which should cover both eventualities.

Code:

Sub WipeOffRng(WipeRange As Range)

Dim wkSheet As Worksheet
Dim Shp As Shape
Dim rngShp As Range

    ' Set the worksheet
    Set wkSheet = WipeRange.Parent

    ' Loop through every shape
    For Each Shp In wkSheet.Shapes

        ' Dtermine the block range
        Set rngShp = Range(Shp.TopLeftCell, Shp.BottomRightCell)

        ' Test for any sort of overlap
        If Not Intersect(WipeRange, rngShp) Is Nothing Then
        ' Test for fully inside
        'If Intersect(WipeRange, rngShp).Address = rngShp.Address Then

            Shp.Delete

        End If

    Loop

End Sub

Sub WipeOffQ()

Dim Shp As Shape
Dim Ans As VbMsgBoxResult

    ' Loop through every shape
    For Each Shp In ActiveSheet.Shapes

        ' Highlight the Shape in question
        Shp.Select

        ' Ask the question
        Ans = MsgBox(Prompt:="Delete shape " & Shp.Name & "?", Buttons:=vbYesNoCancel, Title:="WipeOffQ")

        ' Quit on Cancel
        If Ans = vbCancel Then Exit Sub

        ' Delete on Yes
        If Ans = vbYes Then Shp.Delete

    Loop

End Sub

HTH,
Maccas

Amjad.Mahmoood · September 11th, 2006, 12:24 AM

Maccas, thanks for your response. In line with what you advises I tried the code as follows (but it ends up with an error "Object Variable or With block variable not set))

Sub testit()
WipeOffRng Selection
End Sub

Sub WipeOffRng(WipeRange As Range)

Dim wkSheet As Worksheet
Dim Shp As Shape
Dim rngShp As Range

    ' Set the worksheet
    Set wkSheet = WipeRange.Parent

    ' Loop through every shape
    For Each Shp In wkSheet.Shapes

        ' Dtermine the block range
        Set rngShp = Range(Shp.TopLeftCell, Shp.BottomRightCell)

        ' Test for any sort of overlap
        'If Not Intersect(WipeRange, rngShp) Is Nothing Then
        ' Test for fully inside

        If Intersect(WipeRange, rngShp).Address = rngShp.Address Then

            Shp.Delete

        End If

    Next Shp

End Sub

Amjad.Mahmoood · September 11th, 2006, 12:56 AM

The problem is solved as I made some adjustments as follows.

Sub testit()
WipeOffRng Selection
End Sub

Sub WipeOffRng(WipeRange As Range)
Dim isect As Range
Dim wkSheet As Worksheet
Dim Shp As Shape
Dim rngShp As Range

    ' Set the worksheet
    Set wkSheet = WipeRange.Parent

    ' Loop through every shape
    For Each Shp In wkSheet.Shapes

        ' Dtermine the block range
        Set rngShp = Range(Shp.TopLeftCell, Shp.BottomRightCell)

        ' Test for any sort of overlap
        'If Not Intersect(WipeRange, rngShp) Is Nothing Then
        ' Test for fully inside

        Set isect = Intersect(WipeRange, rngShp)
        If isect Is Nothing Then

            Else
            Shp.Delete

        End If

    Next Shp

End Sub

maccas · September 11th, 2006, 03:39 AM

Sorry Amjad - that's what comes of not testing your code before posting! I'm glad you could debug this. As I think you've gathered the reason for my code crashing is because the fully inside test is comparing the address of the shape's range with the address of the intersection between the shape and the wiperange. In the case where there is no overlap, the intersection equates to the nothing object and the address property of the nothing object cannot be resolved hence the error.

There is a slight subtlety to my code which you may have passed over in that I was trying to offer you the option to test whether the shape was fully inside the wiperange or whether there was just any sort of overlap. To be clear, I thought I'd post both tests in case you'd like to implement either of them:

Code:

        ' Test for any sort of overlap
        If Not Intersect(WipeRange, rngShp) Is Nothing Then Shp.Delete

        ' -------- OR --------

        ' Test for fully inside
        If Not Intersect(WipeRange, rngShp) Is Nothing Then
            If Intersect(WipeRange, rngShp).Address = rngShp.Address Then Shp.Delete
        End If

Maccas