Заинтересовала проблема с памятью, а после вспомнил что сам использую
проверку на врезку регионов друг в друга, только для других целей.
Проверил данную проблему у себя, её не оказалось. Но как только ради
интереса сделал цикл в цикле и запустил на обработку файл 13Mb,
с 32800-ми контурами, наваленными друг на друга, и у меня не
хватило свободного места на винте.
Результат получил следующий: IV Пень, RIMM-1066 512Mb,
1 час работы - обработано 640 контуров, сожрано 45Mb оперативки и
675Mb на винте.
Выяснил, что винт жрёт Undo. Поэтому его необходимо отключать.
С оперативкой не поможет, но винт шерстить перестанет.
Отключить можно, только через SendCommand. В VBA ни каких методов для
этого нет, а системная переменная UNDOCTL только для чтения. Поэтому,
лучше вручную, перед запуском цикла.
В ниже приведённом коде, добавил данную строку перед самым циклом.
Кроме того снизил количество циклов в два раза, так как проверку
делаем обоюдно, сразу для обоих контуров, то нет смысла повторять её в
дальнейшем. Поэтому, Каждый последующий полигон проверяем начиная не с
первого, а со следующего, за проверяемым. То есть, с каждым проверенным
контуром мы уменьшаем число проверок на единицу.
Sub StartProg()
Dim acadObj As AcadEntity
Dim acadObjs(0) As AcadEntity
Dim SelPoligons As AcadSelectionSet
Dim CoordXY As Variant, RegionObj As Variant
Dim NewReg As Boolean
Dim StepN As Byte, Result As Byte
Dim I As Long, J As Long
Dim NReg As String
' Создаём временную коллекцию для проверяемых объектов
With ActiveDocument
For Each SelPoligons In .SelectionSets
If SelPoligons.Name = "$SEL_POLIGONS" Then SelPoligons.Delete: Exit For
Next SelPoligons
Set SelPoligons = .SelectionSets.Add("$SEL_POLIGONS")
End With
' Отфильтровываем объекты, с которыми метод создания регионов не работает
' или не замкнутые объекты. Желательно добавить фильтр и на необходимые слои.
For Each acadObj In ActiveDocument.ModelSpace
Select Case acadObj.ObjectName
Case "AcDb3dPolyline", "AcDb2dPolyline", "AcDbPolyline", "AcDbSpline"
If acadObj.ObjectName = "AcDbSpline" Then _
CoordXY = acadObj.ControlPoints _
Else: CoordXY = acadObj.Coordinates
If acadObj.ObjectName = "AcDbPolyline" Then _
StepN = UBound(acadObj.Coordinate(0)) + 1 _
Else StepN = 3
If CoordXY(UBound(CoordXY) + 1 - StepN) <> CoordXY(0) Or _
CoordXY(UBound(CoordXY) + 2 - StepN) <> CoordXY(1) Then
If acadObj.Closed = False Then GoTo NextFor
End If
Set acadObjs(0) = acadObj
Case "AcDbSolid", "AcDbRegion", "AcDbCircle", "AcDbEllipse"
Set acadObjs(0) = acadObj
Case Else: GoTo NextFor
End Select
SelPoligons.AddItems acadObjs
NextFor:
Next acadObj
If SelPoligons.Count < 2 Then _
MsgBox "В рисунке менее 2-х полигонов!", vbExclamation: Exit Sub
' Отключаем Undo
ActiveDocument.SendCommand "_undo _Control _None" & vbCr
' Открываем счётчик (Просто форма с именем UserForm1 и
' текстом с именем Label1)
UserForm1.Show vbModeless
With UserForm1.Label1
NReg = " - " & SelPoligons.Count - 1
ReDim RegionObj(0) As Variant
' Запускаем цикл на выполнение
For I = 0 To SelPoligons.Count - 2
.Caption = I & NReg: DoEvents
NewReg = True
Set RegionObj(0) = Nothing
For J = I + 1 To SelPoligons.Count - 1
Result = PoligonToPoligon(NewReg, SelPoligons(I), SelPoligons(J), RegionObj)
Select Case Result
Case 4: ' Код если один или оба полигона были не корректными
Case 3: ' Код если полигоны пересекаются
Case 2: ' Код если полигон 2 внутри полигона 1
Case 1: ' Код если полигон 1 внутри полигона 2
Case 0: ' Код если полигоны не зависимы друг от друга
End Select
Next J
If Not (RegionObj(0) Is Nothing) Then RegionObj(0).Delete
Next I
SelPoligons.Delete
.Caption = I & NReg
End With
' Восстанавливаем режим Undo
ActiveDocument.SendCommand "_undo _Control _All" & vbCr
End Sub
' Функция контроля вложенности контуров
Function PoligonToPoligon(NewReg As Boolean, PoligonObj1 As AcadEntity, _
PoligonObj2 As AcadEntity, RegionObj1 As Variant) As Byte
Static RegAreaOld As Double
Dim RegionSumm As AcadEntity
Dim ArrayPoligon(0) As AcadEntity
Dim RegionObj2 As Variant
Dim IntPoints As Variant
Dim XYmin1 As Variant, XYmax1 As Variant, XYmin2 As Variant, XYmax2 As Variant
' Делаем простейшую проверку на явный разброс контуров
PoligonObj1.GetBoundingBox XYmin1, XYmax1
PoligonObj2.GetBoundingBox XYmin2, XYmax2
If XYmax2(0) < XYmin1(0) Or XYmin2(0) > XYmax1(0) Or _
XYmax2(1) < XYmin1(1) Or XYmin2(1) > XYmax1(1) Then _
PoligonToPoligon = 0: Exit Function
' Делаем проверку на пересечение контуров
IntPoints = PoligonObj1.IntersectWith(PoligonObj2, acExtendNone)
If UBound(IntPoints) > 1 Then PoligonToPoligon = 3: Exit Function
' Создаём необходимые регионы
On Error Resume Next
With ActiveDocument.ModelSpace
If NewReg = True Then
If PoligonObj1.ObjectName = "AcDbRegion" Then
ReDim RegionObj1(0) As Variant
Set RegionObj1(0) = PoligonObj1.Copy
Else
Set ArrayPoligon(0) = PoligonObj1
RegionObj1 = .AddRegion(ArrayPoligon)
If Err <> 0 Then
PoligonToPoligon = 4
On Error GoTo 0: Exit Function
End If
RegAreaOld = RegionObj1(0).Area
End If
NewReg = False
End If
If PoligonObj2.ObjectName = "AcDbRegion" Then
ReDim RegionObj2(0) As Variant
Set RegionObj2(0) = PoligonObj2.Copy
Else
Set ArrayPoligon(0) = PoligonObj2
RegionObj2 = .AddRegion(ArrayPoligon)
End If
End With
If Err <> 0 Then PoligonToPoligon = 4: Exit Function
On Error GoTo 0
' Выполняем проверку на вхождение регионов друг в друга
Set RegionSumm = RegionObj1(0).Copy
RegionSumm.Boolean acIntersection, RegionObj2(0)
If RegionSumm.Area = 0 Then
PoligonToPoligon = 0
ElseIf RegionSumm.Area = RegAreaOld Then
PoligonToPoligon = 1
ElseIf RegionSumm.Area < RegAreaOld Then
PoligonToPoligon = 2
End If
RegionSumm.Delete
End Function
