View Single Post
  #8  
Old 01-04-2010, 21:49
runflacruiser's Avatar
runflacruiser runflacruiser is offline
Senior Member
 
Join Date: Jun 2009
Location: Pigeon Forge, TN USA
Posts: 811
Default

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