'Преобразование абриса в отдельный объект (некорректные преобразования откатываются)
Sub OutlineToObject()
Dim unit As cdrUnit
Dim selectedShRange As ShapeRange
Dim shSrc As shape 'исходный shape
Dim shCopyMain As shape 'дубликат для преобразований
Dim shCopyOutLine As shape 'объект-абрис, полученный после преобразования shCopyMain
If ActiveSelectionRange.count = 0 Then
MsgBox "Выделите один или несколько объектов и повторите операцию."
Exit Sub
End If
ActiveDocument.BeginCommandGroup ("OutlineToObject")
unit = ActiveDocument.unit
ActiveDocument.unit = cdrMillimeter
'на период преобразований выделение снимается (ускорение работы операций)
Set selectedShRange = ActiveSelectionRange
ActiveSelectionRange.RemoveFromSelection
For Each shSrc In selectedShRange
If (shSrc.CanHaveOutline) Then
If (shSrc.Outline.Type <> cdrNoOutline) Then
Set shCopyMain = shSrc.Duplicate(0, 0) 'дубликат для преобразований
Set shCopyOutLine = shCopyMain.Outline.ConvertToObject 'преобразование абриса дубликата в объект
'есть пересечения => преобразование выполнено некорректно => преобразование откатывается
If (HasIntersection(shCopyOutLine)) Then
shCopyMain.Delete
shCopyOutLine.Delete
Else
shSrc.Delete
If (shCopyMain.Fill.Type = cdrNoFill) Then shCopyMain.Delete
End If
End If
End If
Next
'выделение объектов, преобразование которых выполняется некорректно
selectedShRange.CreateSelection
ActiveDocument.unit = unit
ActiveDocument.EndCommandGroup
End Sub
'Проверка наличия у shape'а "бубликов" (т.е. имеет ли shape пересекающиеся фрагменты (subpath))
Function HasIntersection(ByRef sh As shape) As Boolean
Dim intersections As CrossPoints
Dim find As Boolean
Dim i1 As Integer, i2 As Integer
Dim path1 As SubPath, path2 As SubPath
find = False
For i1 = 1 To sh.Curve.SubPaths.count - 1
'исключение из проверки фрагментов (subpath) с пренебрежимо малой длиной
If (Not PathLengthIsNegligible(sh.Curve.SubPaths.Item(i1))) Then
For i2 = i1 + 1 To sh.Curve.SubPaths.count
'исключение из проверки фрагментов (subpath) с пренебрежимо малой длиной
If (Not PathLengthIsNegligible(sh.Curve.SubPaths.Item(i2))) Then
Set intersections = sh.Curve.SubPaths.Item(i1).GetIntersections(sh.Curve.SubPaths.Item(i2))
If (intersections.count > 0) Then
find = True
Exit For
End If
If (find) Then Exit For
End If
Next i2
End If
Next i1
HasIntersection = find
End Function
'Проверка, является ли фрагмент (path) пренебрежимо коротким
Function PathLengthIsNegligible(ByRef path As SubPath)
Const unit = cdrMillimeter
Const tolerance = 0.01
Dim negligible As Boolean
ActiveDocument.unit = cdrMillimeter
negligible = False
If (path.Segments.count = 1) Then
If (path.Length <= tolerance) Then
negligible = True
End If
End If
PathLengthIsNegligible = negligible
End Function
