OberonPlace.com Forums

OberonPlace.com Forums (http://forum.oberonplace.com/index.php)
-   Feature requests/wishlist (http://forum.oberonplace.com/forumdisplay.php?f=33)
-   -   Jeff's Delete Small Objects macro (http://forum.oberonplace.com/showthread.php?t=6897)

gorgo2 19-03-2010 17:41

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!:P

-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


shelbym 19-03-2010 17:49

ActiveSelection
 
Just change:

Code:

Set sr = ActiveDocument.ActiveLayer.FindShapes
to

Code:

Set sr = ActiveSelectionRange.Shapes.FindShapes
-Shelby

gorgo2 19-03-2010 18:12

Cool! :D
Thanks Shelby.

-Greg

gorgo2 01-04-2010 15:31

Hi Y'all. Is it possible to add a progress bar somewhere so I know the macro is 'working..'?

runflacruiser 01-04-2010 15:50

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

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


-John

shelbym 01-04-2010 15:57

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

gorgo2 01-04-2010 16:18

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?:confused:

runflacruiser 01-04-2010 21:49

Totally untested but try this:

Code:


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

    If s.Type = cdrCurveShape Then
        stat.BeginProgress CanAbort:=True
        For i = s.Curve.SubPaths.Count To 1 Step -1
            If s.Curve.SubPaths(i).Length < tol Then
                s.Curve.SubPaths(i).Delete
                stat.UpdateProgress
                If stat.Aborted Then Exit For
            End If
        Next i
        stat.EndProgress
    End If
   

End Sub

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

    Dim sr As ShapeRange
    Dim s As Shape
    Optimization = True
   
    Set sr = ActiveSelectionRange.Shapes.FindShapes
    stat.BeginProgress CanAbort:=True
   
    For Each s In sr
        RemoveSmallSubpaths s, tol
        stat.UpdateProgress
        If stat.Aborted Then Exit For
    Next s
    Optimization = False
    stat.EndProgress

    Application.Refresh

    ActiveDocument.EndCommandGroup
End Sub

Public Sub DeleteSmallObjects()
    RemoveSmallCurves 0.1
End Sub

-John

gorgo 01-04-2010 22:17

1 Attachment(s)
I get this error John. "Compile error" Variable not defined.
Attachment 886

runflacruiser 02-04-2010 10:10

Hi.
Had a little extra time this morning.
This one's tested and works great.

Code:


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

    If s.Type <> cdrCurveShape Then
        s.ConvertToCurves
    End If
    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 Sub

Public Sub RemoveSmallCurves(tol As Double)
    ActiveDocument.BeginCommandGroup "Remove small curves"
    Dim stat As AppStatus
    Dim sr As ShapeRange
    Dim s As Shape
    'Optimization = True
    Set stat = Application.Status

    Set sr = ActiveSelectionRange.Shapes.FindShapes
    stat.BeginProgress CanAbort:=True
   
    For Each s In sr
        RemoveSmallSubpaths s, tol
        stat.UpdateProgress
        If stat.Aborted Then Exit For
    Next s
   
    stat.EndProgress
    'Optimization = False
    'Application.Refresh

    ActiveDocument.EndCommandGroup
End Sub

Public Sub DeleteSmallObjects()
    RemoveSmallCurves 0.1
End Sub

-John


All times are GMT -5. The time now is 21:32.

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