OberonPlace.com Forums  

Go Back   OberonPlace.com Forums > Developer Forums > VBA > CorelDRAW/Corel DESIGNER VBA

Reply
 
Thread Tools Search this Thread Display Modes
  #1  
Old 14-05-2008, 07:06
keytecstaff
Guest
 
Posts: n/a
Talking 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.
Reply With Quote
  #2  
Old 14-05-2008, 13:57
shelbym's Avatar
shelbym shelbym is offline
Senior Member
 
Join Date: Nov 2002
Location: Cheyenne, WY
Posts: 1,769
Blog Entries: 9
Send a message via ICQ to shelbym Send a message via AIM to shelbym Send a message via MSN to shelbym Send a message via Yahoo to shelbym
Default Easy enough...

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!! *****

Last edited by shelbym; 14-05-2008 at 23:58.
Reply With Quote
  #3  
Old 14-05-2008, 19:26
knowbodynow knowbodynow is offline
Senior Member
 
Join Date: Mar 2006
Location: Hatsukaichi near Hiroshima
Posts: 430
Default

Quote:
Originally Posted by shelbym View Post
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)
Reply With Quote
  #4  
Old 14-05-2008, 23:45
shelbym's Avatar
shelbym shelbym is offline
Senior Member
 
Join Date: Nov 2002
Location: Cheyenne, WY
Posts: 1,769
Blog Entries: 9
Send a message via ICQ to shelbym Send a message via AIM to shelbym Send a message via MSN to shelbym Send a message via Yahoo to shelbym
Default Sorry...

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.
Code:
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 *******************

Code:
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

Last edited by shelbym; 12-06-2008 at 11:00. Reason: Updated for empty strings, Updated to ignore Bitmaps
Reply With Quote
  #5  
Old 15-05-2008, 04:53
keytecstaff
Guest
 
Posts: n/a
Thumbs up

Hi,

It works a charm.

Many thanks Shelby!
Reply With Quote
  #6  
Old 15-05-2008, 20:01
knowbodynow knowbodynow is offline
Senior Member
 
Join Date: Mar 2006
Location: Hatsukaichi near Hiroshima
Posts: 430
Default

Thanks, Shelby that's very kind of you.

Best wishes,

Chris
Reply With Quote
  #7  
Old 15-05-2008, 20:15
Alex's Avatar
Alex Alex is offline
Administrator
 
Join Date: Nov 2002
Posts: 1,940
Blog Entries: 4
Default

Hey, Shelby, let me criticize your macro

The following lines:

Code:
    srAll.RemoveRange srAll.FindAnyOfType(7) 'Remove any groups
    srAll.RemoveRange srAll.FindAnyOfType(9) 'Remove any Guidelines
could be replaced with:

Code:
srAll.RemoveRange srAll.FindAnyOfType(cdrGroupShape, cdrGuidelineShape)
Reply With Quote
  #8  
Old 28-05-2008, 05:19
keytecstaff
Guest
 
Posts: n/a
Question

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!
Reply With Quote
  #9  
Old 28-05-2008, 05:40
keytecstaff
Guest
 
Posts: n/a
Default

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!
Attached Files
File Type: cdr TEXTPROB.cdr (12.7 KB, 22 views)
Reply With Quote
  #10  
Old 28-05-2008, 22:42
shelbym's Avatar
shelbym shelbym is offline
Senior Member
 
Join Date: Nov 2002
Location: Cheyenne, WY
Posts: 1,769
Blog Entries: 9
Send a message via ICQ to shelbym Send a message via AIM to shelbym Send a message via MSN to shelbym Send a message via Yahoo to shelbym
Default Code Update....

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
Reply With Quote
Reply


Currently Active Users Viewing This Thread: 1 (0 members and 1 guests)
 
Thread Tools Search this Thread
Search this Thread:

Advanced Search
Display Modes

Posting Rules
You may not post new threads
You may not post replies
You may not post attachments
You may not edit your posts

BB code is On
Smilies are On
[IMG] code is On
HTML code is Off

Forum Jump


All times are GMT -5. The time now is 09:05.


Powered by vBulletin® Version 3.8.1
Copyright ©2000 - 2019, Jelsoft Enterprises Ltd.
Copyright © 2011, Oberonplace.com