Find and delete objects with no fill or outline

Hi,

I need a macro which can find and delete any objects with no fills or outlines.

Many thanks.

[shelbym]

You may download my free Quick Fills / Outlines Macro. It will do this and much much more....

MacroMonter.com

-Shelby

*****Forgive me it is not free, see my next post which is 100% FREE!! *****

[knowbodynow]

Originally Posted by shelbym

You may download my free Quick Fills / Outlines Macro. It will do this and much much more....

MacroMonter.com

-Shelby

Unless I'm missing something, your Quickfill/Outlines Macro actually costs $9.95, reduced from $19.95. Nothing about free.

Chris (Hunt)

[shelbym]

I am so sorry, guess I am charging for that one. Alright to make it up I will give you two for one. Here is a an X3 version and a new improved X4 version that uses CQL to make life so much simpler.

Sub DeleteNoFillandOutlineX3()
    Dim s As Shape
    Dim srAll As ShapeRange
    Dim srNoFillOutline As New ShapeRange
    Dim sString As String
    
    Set srAll = ActivePage.Shapes.FindShapes()
    srAll.RemoveRange srAll.FindAnyOfType(cdrGroupShape, cdrGuidelineShape, cdrBitmapShape)
    
    For Each s In srAll
        If s.Fill.Type = cdrNoFill And s.Outline.Type = cdrNoOutline Then srNoFillOutline.Add s
        'Added to delete a single space text shape
        If s.Type = cdrTextShape Then
            If Trim(s.Text.Story.Text) = "" Then srNoFillOutline.Add s
        End If
    Next s
    
    'Report back what was found from search
    If srNoFillOutline.Shapes.Count > 0 Then
        response = MsgBox("Number of shapes to be deleted: " & srNoFillOutline.Shapes.Count, vbYesNo, "Delete No Fill and Outline")
        If response = vbYes Then srNoFillOutline.Delete
    Else
        MsgBox "No Shapes Found.", , "Delete No Fill and Outline"
    End If
End Sub

******************* X4 Version *******************

Sub DeleteNoFillandOutlineX4()
    Dim srNoFillOutline As ShapeRange
    Dim srEmptyText As ShapeRange
    
    'Using CQL we can easily find the shapes with no outline and fill
    Set srNoFillOutline = ActivePage.Shapes.FindShapes(Query:="@fill.type = 'none' and @outline.type = 'none' and @type <> 'group' and @type <> 'bitmap'")
    Set srEmptyText = ActivePage.Shapes.FindShapes(Query:="@type.StartsWith('text:') and @com.Text.Story.Text.Trim().empty()")
    
    'Report back what was found from search
    If (srNoFillOutline.Shapes.Count > 0) Or (srEmptyText.Shapes.Count > 0) Then
        response = MsgBox("Number of shapes to be deleted: " & srNoFillOutline.Shapes.Count + srEmptyText.Shapes.Count, vbYesNo, "Delete No Fill and Outline")
        If response = vbYes Then
            srNoFillOutline.Delete
            srEmptyText.Delete
        End If
    Else
        MsgBox "No Shapes Found.", , "Delete No Fill and Outline"
    End If
End Sub

Let me know if you find any bugs or errors.

-Shelby

Hi,

It works a charm.

Many thanks Shelby!

[knowbodynow]

Thanks, Shelby that's very kind of you.

Best wishes,

Chris

[Alex]

Hey, Shelby, let me criticize your macro

The following lines:

    srAll.RemoveRange srAll.FindAnyOfType(7) 'Remove any groups
    srAll.RemoveRange srAll.FindAnyOfType(9) 'Remove any Guidelines

could be replaced with:

srAll.RemoveRange srAll.FindAnyOfType(cdrGroupShape, cdrGuidelineShape)

Hi,

I have just found a problem with this macro. It will not find any Artistic Text shapes with no fill or outlines.

Please can this macro be ammended to pick up on any text with no fill or outlines?

Many thanks!

Sorry,

The macro does find text shapes with no fills and no outlines.

I have attached a CorelDraw X3 file with an object that I get alot when importing PDF files.

Can anyone tell me a way I can find these objects and delete them?

Many thanks!

[shelbym]

Alright I updated the code to use Alex's tip and to search for empty strings. Let me know how it works...

Thanks again Alex!!!

-Shelby