View Single Post
  #7  
Old 01-04-2010, 17: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