View Single Post
Old 01-04-2010, 16:18
gorgo2 gorgo2 is offline
Senior Member
Join Date: Feb 2010
Posts: 107

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.
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
            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
            If stat.Aborted Then Exit For
        End If
    Next n
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


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