[VBA]有关一段VBA程序优化的问题
Public Function CheckRegionIntersect(ByVal player As String) '//////////////////////检查多边形面域是否相交On Error GoTo ERR_HANDLE:
Dim psel As AcadSelectionSet
Dim pENty As AcadEntity
Dim s_Obj() As AcadEntity
ReDim s_Obj(0) As AcadEntity
Dim pPolyline As AcadPolyline
Dim pLWPolyline As AcadLWPolyline
Dim pCNT As Integer
Dim i, j As Integer
i = 0
For Each pENty In ThisDrawing.ModelSpace
If pENty.layer = player Then
If UCase(pENty.ObjectName) = "ACDBPOLYLINE" Then
Set pLWPolyline = pENty
If pLWPolyline.Closed = True Then
If i = 0 Then
Set s_Obj(0) = pENty
Else
ReDim Preserve s_Obj(i) As AcadEntity
Set s_Obj(i) = pENty
End If
i = i + 1
End If
ElseIf UCase(pENty.ObjectName) = "ACDB2DPOLYLINE" Then
Set pPolyline = pENty
If pPolyline.Closed = True Then
If i = 0 Then
Set s_Obj(0) = pENty
Else
ReDim Preserve s_Obj(i) As AcadEntity
Set s_Obj(i) = pENty
End If
i = i + 1
End If
End If
End If
Next
'//////////////判断图型中是否有选择集s_AAA如果有将选择集清空，如果没有则直接新建选择集s_AAA
If ThisDrawing.SelectionSets.Count = 0 Then Set psel = ThisDrawing.SelectionSets.Add("s_tmp"): GoTo uuu:
For j = 0 To ThisDrawing.SelectionSets.Count - 1
If ThisDrawing.SelectionSets.Item(j).Name = "s_tmp" Then
Set psel = ThisDrawing.SelectionSets.Item(j)
psel.Clear
Exit For
End If
If j = ThisDrawing.SelectionSets.Count - 1 Then
Set psel = ThisDrawing.SelectionSets.Add("s_tmp")
End If
Next
uuu: psel.AddItems s_Obj '/////////////////////将实体数组对象添加到新增加的选择集中
CreateLayer '创建新图层
For j = 0 To ThisDrawing.Layers.Count - 1
If ThisDrawing.Layers.Item(j).Name = "dan" Then
ThisDrawing.ActiveLayer = ThisDrawing.Layers.Item(j)
Exit For
End If
Next
'/////////////////将选择集中的所有要素转换成面域
Dim pRegion As Variant
Dim pLineObj(0 To 0) As AcadEntity
For i = 0 To psel.Count - 1
Set pLineObj(0) = psel.Item(i)
pRegion = ThisDrawing.ModelSpace.AddRegion(pLineObj)
Next
psel.Clear
Set pENty = Nothing
'/////////////将所有面域对象添加到psel选择集中
Dim s_RegionObj() As AcadEntity
ReDim s_RegionObj(0) As AcadEntity
j = 0
For Each pENty In ThisDrawing.ModelSpace
If pENty.layer = "dan" Then
If UCase(pENty.ObjectName) = "ACDBREGION" Then
If j = 0 Then
Set s_RegionObj(0) = pENty
Else
ReDim Preserve s_RegionObj(j) As AcadEntity
Set s_RegionObj(j) = pENty
End If
j = j + 1
End If
End If
Next
psel.AddItems s_RegionObj '/////////添加对象
Dim pRegion1 As AcadRegion
Dim pRegion2 As AcadRegion
For i = 0 To psel.Count - 2
For j = i + 1 To psel.Count - 1
Set pRegion1 = psel.Item(i).Copy
Set pRegion2 = psel.Item(j).Copy
InterSectRegion pRegion1, pRegion2
Next
Next
For i = 0 To psel.Count - 1
psel.Item(i).Delete
Next
Dim tmpRegion As AcadRegion
Set pENty = Nothing
For Each pENty In ThisDrawing.ModelSpace
If UCase(pENty.ObjectName) = "ACDBREGION" Then
Set tmpRegion = pENty
drawcircle tmpRegion.Centroid
pCNT = pCNT + 1
End If
Next
MsgBox "数据处理完成" & Chr(10) & "共检查到" + CStr(pCNT) + "处交错"
ERR_HANDLE:
psel.Delete
End Function
Private Function InterSectRegion(ByVal pRegion1 As AcadRegion, ByVal pRegion2 As AcadRegion) '///面相交
Dim NewRegion As AcadRegion
Dim parea As Double
parea = pRegion1.Area
pRegion1.Boolean acIntersection, pRegion2
If pRegion1.Area = 0 Then
pRegion1.Delete
End If
End Function
以上是我写的一段用于检查 面交错 的程序.程序实现了预定功能.但遇到的问题是当图层中的图元数量有上千个的时候,程序就会出现死锁的现象,进而导致程序崩溃.
我想请教大家的是,我的这段代码该如何修改,才能在处理大数据量(3000-8000图元/层)的时候,不会出现死锁的现象,谢谢
<P>大家能给点建议么</P> 可以把全部代码贴上来看看吗？ 把全部代码发给我看看？ 邮箱 chy_dt@163.com
页:
[1]