OberonPlace.com Forums  

Go Back   OberonPlace.com Forums > Corel User Forums > CorelDRAW > Feature requests/wishlist

Reply
 
Thread Tools Search this Thread Display Modes
  #1  
Old 19-03-2010, 17:41
gorgo2 gorgo2 is offline
Senior Member
 
Join Date: Feb 2010
Posts: 107
Default Jeff's Delete Small Objects macro

Hi there. Could you please add a feature in this macro where it will only search and delete small objects within the selected area?

Thanks!

-Greg

Code:
Option Explicit

Public Sub RemoveSmallSubpaths(s As Shape, tol As Double)
    Dim i As Integer

    If s.Type = cdrCurveShape Then
        For i = s.Curve.SubPaths.Count To 1 Step -1
            If s.Curve.SubPaths(i).Length < tol Then
                s.Curve.SubPaths(i).Delete
            End If
        Next i
    End If

End Sub

Public Sub RemoveSmallCurves(tol As Double)
    ActiveDocument.BeginCommandGroup "Remove small curves"

    Dim sr As ShapeRange
    Dim s As Shape

    Set sr = ActiveDocument.ActiveLayer.FindShapes

    Optimization = True
    For Each s In sr
        RemoveSmallSubpaths s, tol
    Next s
    Optimization = False

    Application.Refresh

    ActiveDocument.EndCommandGroup
End Sub

Public Sub RemoveSmallCurves1()
    RemoveSmallCurves 0.1
End Sub
Reply With Quote
  #2  
Old 19-03-2010, 17:49
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 ActiveSelection

Just change:

Code:
Set sr = ActiveDocument.ActiveLayer.FindShapes
to

Code:
Set sr = ActiveSelectionRange.Shapes.FindShapes
-Shelby
Reply With Quote
  #3  
Old 19-03-2010, 18:12
gorgo2 gorgo2 is offline
Senior Member
 
Join Date: Feb 2010
Posts: 107
Default

Cool!
Thanks Shelby.

-Greg
Reply With Quote
  #4  
Old 01-04-2010, 15:31
gorgo2 gorgo2 is offline
Senior Member
 
Join Date: Feb 2010
Posts: 107
Default

Hi Y'all. Is it possible to add a progress bar somewhere so I know the macro is 'working..'?
Reply With Quote
  #5  
Old 01-04-2010, 15:50
runflacruiser's Avatar
runflacruiser runflacruiser is offline
Senior Member
 
Join Date: Jun 2009
Location: Pigeon Forge, TN USA
Posts: 811
Default

Yes.
See this.
One of the most awesome posts on the forum.

http://forum.oberonplace.com/showthread.php?t=376


-John
Reply With Quote
  #6  
Old 01-04-2010, 15: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 Progress Bar

You can use the built in ProgressBar. However on a macro like this they should be lightning fast. ;-)

Example here: ProgressBar

Best of luck,

-Shelby
Reply With Quote
  #7  
Old 01-04-2010, 16:18
gorgo2 gorgo2 is offline
Senior Member
 
Join Date: Feb 2010
Posts: 107
Default

Well it's not lightning fast if you have 4,000 small objects to delete. It takes at leas 15 seconds to complete and I want users to know that the macro is working. Here is how I've incorporated the progress bar code with the remove.small.objects macro.
Code:
Option Explicit
Public Sub RemoveSmallSubpaths(s As Shape, tol As Double)
    Dim i As Integer

    If s.Type = cdrCurveShape Then
        For i = s.Curve.SubPaths.Count To 1 Step -1
            If s.Curve.SubPaths(i).Length < tol Then
                s.Curve.SubPaths(i).Delete
            End If
        Next i
    End If

End Sub
Sub ShowProgress()
    Dim doc As Document
    Dim stat As AppStatus
    Dim n As Long
    
    Set doc = CreateDocument
    Set stat = Application.Status
    stat.BeginProgress CanAbort:=True
    For n = 1 To 1000
        doc.ActiveLayer.CreateRectangle2 Rnd() * 8, Rnd() * 11, Rnd() * 5, Rnd() * 5
        If (n Mod 10) = 0 Then
            stat.UpdateProgress
            If stat.Aborted Then Exit For
        End If
    Next n
    stat.EndProgress
End Sub
Public Sub RemoveSmallCurves(tol As Double)
    ActiveDocument.BeginCommandGroup "Remove small curves"

    Dim sr As ShapeRange
    Dim s As Shape

    Set sr = ActiveSelectionRange.Shapes.FindShapes

    Optimization = True
    For Each s In sr
        RemoveSmallSubpaths s, tol
    Next s
    Optimization = False

    Application.Refresh

    ActiveDocument.EndCommandGroup
End Sub

Public Sub DeleteSmallObjects()
    RemoveSmallCurves 0.1
End Sub
so something is wrong because it does not show the progress bar...probably something I missed?
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

Similar Threads
Thread Thread Starter Forum Replies Last Post
Global Macro delete Michael Cervantes CorelDRAW/Corel DESIGNER VBA 17 16-11-2010 08:11
Find and delete objects with no fill or outline keytecstaff CorelDRAW/Corel DESIGNER VBA 17 22-06-2010 23:34
Delete Segment macro addendum request Rakker New product ideas 1 18-10-2008 15:47
Delete matching objects click101 CorelDRAW/Corel DESIGNER VBA 2 02-06-2008 16:14
Delete small objects macro Jeff Harrison New product ideas 3 19-05-2007 12:19


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


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