[VBA]有关一段VBA程序优化的问题

Terry1021

2. Public Function CheckRegionIntersect(ByVal player As String)    '//////////////////////检查多边形面域是否相交
3.   On Error GoTo ERR_HANDLE:
4.        Dim psel As AcadSelectionSet
5.        Dim pENty As AcadEntity
6.        Dim s_Obj() As AcadEntity
7.        ReDim s_Obj(0) As AcadEntity
8.        Dim pPolyline As AcadPolyline
9.        Dim pLWPolyline As AcadLWPolyline
10.        Dim pCNT As Integer
11.        Dim i, j As Integer
12.        i = 0
13.        For Each pENty In ThisDrawing.ModelSpace
14.          If pENty.layer = player Then
15.            If UCase(pENty.ObjectName) = "ACDBPOLYLINE" Then
16.               Set pLWPolyline = pENty
17.                   If pLWPolyline.Closed = True Then
18.                           If i = 0 Then
19.                             Set s_Obj(0) = pENty
20.                           Else
21.                              ReDim Preserve s_Obj(i) As AcadEntity
22.                                 Set s_Obj(i) = pENty
23.                           End If
24.                            i = i + 1
25.                   End If
26.            ElseIf UCase(pENty.ObjectName) = "ACDB2DPOLYLINE" Then
27.                Set pPolyline = pENty
28.                   If pPolyline.Closed = True Then
29.                           If i = 0 Then
30.                             Set s_Obj(0) = pENty
31.                           Else
32.                              ReDim Preserve s_Obj(i) As AcadEntity
33.                                 Set s_Obj(i) = pENty
34.                           End If
35.                           i = i + 1
36.                    End If
37.            End If
38.         End If
39.      Next
40. '//////////////判断图型中是否有选择集s_AAA如果有将选择集清空，如果没有则直接新建选择集s_AAA
41.       If ThisDrawing.SelectionSets.Count = 0 Then Set psel = ThisDrawing.SelectionSets.Add("s_tmp"): GoTo uuu:
42.       For j = 0 To ThisDrawing.SelectionSets.Count - 1
43.           If ThisDrawing.SelectionSets.Item(j).Name = "s_tmp" Then
44.                Set psel = ThisDrawing.SelectionSets.Item(j)
45.                    psel.Clear
46.                    Exit For
47.           End If
48.           If j = ThisDrawing.SelectionSets.Count - 1 Then
49.               Set psel = ThisDrawing.SelectionSets.Add("s_tmp")
50.           End If
51.       Next
52.       
53. uuu:     psel.AddItems s_Obj       '/////////////////////将实体数组对象添加到新增加的选择集中
54. CreateLayer    '创建新图层
55. For j = 0 To ThisDrawing.Layers.Count - 1
56.       If ThisDrawing.Layers.Item(j).Name = "dan" Then
57.            ThisDrawing.ActiveLayer = ThisDrawing.Layers.Item(j)
58.             Exit For
59.       End If
60. Next
61.   '/////////////////将选择集中的所有要素转换成面域
62.   Dim pRegion As Variant
63.   Dim pLineObj(0 To 0) As AcadEntity
64.   
65.   For i = 0 To psel.Count - 1
66.      Set pLineObj(0) = psel.Item(i)
67.      pRegion = ThisDrawing.ModelSpace.AddRegion(pLineObj)
68.   Next
69.   
70.        psel.Clear
71.       
72.        Set pENty = Nothing
73.         '/////////////将所有面域对象添加到psel选择集中
74.         Dim s_RegionObj() As AcadEntity
75.         ReDim s_RegionObj(0) As AcadEntity
76.         j = 0
77.        For Each pENty In ThisDrawing.ModelSpace
78.          If pENty.layer = "dan" Then
79.            If UCase(pENty.ObjectName) = "ACDBREGION" Then
80.                If j = 0 Then
81.                   Set s_RegionObj(0) = pENty
82.                Else
83.                    ReDim Preserve s_RegionObj(j) As AcadEntity
84.                   Set s_RegionObj(j) = pENty
85.                End If
86.                j = j + 1
87.            End If
88.         End If
89.        Next
90.        psel.AddItems s_RegionObj   '/////////添加对象
92.        Dim pRegion1 As AcadRegion
93.        Dim pRegion2 As AcadRegion
94.        For i = 0 To psel.Count - 2
95.            For j = i + 1 To psel.Count - 1
96.                  Set pRegion1 = psel.Item(i).Copy
97.                  Set pRegion2 = psel.Item(j).Copy
98.                InterSectRegion pRegion1, pRegion2
99.            Next
100.        Next
101.       
102.        For i = 0 To psel.Count - 1
103.            psel.Item(i).Delete
104.        Next
105.        Dim tmpRegion As AcadRegion
106.        Set pENty = Nothing
107.        For Each pENty In ThisDrawing.ModelSpace
108.            If UCase(pENty.ObjectName) = "ACDBREGION" Then
109.                Set tmpRegion = pENty
110.                   drawcircle tmpRegion.Centroid
111.                   pCNT = pCNT + 1
112.            End If
113.        Next
114.        MsgBox "数据处理完成" & Chr(10) & "共检查到" + CStr(pCNT) + "处交错"
115. ERR_HANDLE:
116.     psel.Delete
117. End Function
119. Private Function InterSectRegion(ByVal pRegion1 As AcadRegion, ByVal pRegion2 As AcadRegion) '///面相交
120. Dim NewRegion As AcadRegion
121. Dim parea As Double
122.     parea = pRegion1.Area
123.     pRegion1.Boolean acIntersection, pRegion2
124.     If pRegion1.Area = 0 Then
125.        pRegion1.Delete
126.     End If
127. End Function

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图元/层)的时候,不会出现死锁的现象,谢谢

Terry1021

大家能给点建议么

z327692975

可以把全部代码贴上来看看吗？

z327692975

把全部代码发给我看看？ 邮箱 chy_dt@163.com