[原创]Line的startpoint(0)和(1)的不重复排序

兰州人

在做材料表时将其表格线按不重复排序进行处理。

2. Function RemoveOverlap(ByRef Ary)
3.                
4.             On Error Resume Next
5.                
6.             Dim i     As Long
7.                
8.             Dim colTmp     As New Collection
9.             For i = 0 To UBound(Ary) - 1
10.                     colTmp.Add Ary(i), "K" & Ary(i)
11.             Next
12.                
13.             Dim aryTmp()     As String
14.             ReDim aryTmp(colTmp.Count - 1) As String
15.             For i = 0 To colTmp.Count - 1
16.                     aryTmp(i) = colTmp.Item(i + 1)
17.             Next
18.                
19.             Set colTmp = Nothing
20.             RemoveOverlap = aryTmp
21.                
22.     End Function
23. '主程序
24. Sub ll()
25.      Dim xm(1000) As Double, xm1(1000) As Double, TextArray(10000) As String, TextInsertPoint(10000, 2)
26.      Dim tt As AcadText, ll As AcadLine, Ent As AcadEntity
27.      xm_i = 0: xm1_i = 0: tt_i = 0
28.      ''
29.      Dim x1 As Double, y1 As Double
30.      'ReDim xm(1000) As Double, xm1(1000) As Long
31.      For Each Ent In ThisDrawing.ModelSpace
32.        Select Case Ent.ObjectName
33.          Case "AcDbLine"
34.            Set ll = Ent
35.            Select Case ll.Layer
36.              Case "零件表格竖线"
37.                'ReDim xm(xm_i) As Double
38.                xm(xm_i) = Round(ll.EndPoint(0), 0)
39.                'Debug.Print xm_i, xm(xm_i), Round(ll.EndPoint(0), 3)
40.                xm_i = xm_i + 1
41.              Case "零件表格横线"
42.                'ReDim xm1(xm1_i) As Double
43.                xm1(xm1_i) = Round(ll.EndPoint(1), 0)
44.                xm1_i = xm1_i + 1
45.            End Select
46.          Case "AcDbText"
47.            Set tt = Ent
48.              If tt.Layer = "零件表格文本" Then
49.                TextInsertPoint(tt_i, 0) = tt.insertionPoint(0)
50.                TextInsertPoint(tt_i, 1) = tt.insertionPoint(1)
51.                TextArray(tt_i) = tt.textString
52.                tt_i = tt_i + 1
53.              End If
54.         End Select
55.      Next Ent
56.      
57.      MM = RemoveOverlap(xm1)
58.      xx = Bubble_Sort(MM)
59.      
60.      MM = RemoveOverlap(xm)
61.      yy = Bubble_Sort(MM)
62.      Dim gg
63.      ReDim gg(UBound(xx) - 2, UBound(yy) - 2)
64.      
65. For kk = 0 To tt_i - 1
66.     x1 = TextInsertPoint(kk, 1)
67.     For ii = 1 To UBound(xx) - 1
68.       If x1 > xx(ii) And x1 < xx(ii + 1) Then
69.        Exit For
70.       End If
71.     Next ii
72. y1 = Val(TextInsertPoint(kk, 0))
73. For jj = 1 To UBound(yy) - 1
74.       If y1 > yy(jj) And y1 < yy(jj + 1) Then
75.        Exit For
76.       End If
77.     Next jj
78.     gg(ii - 1, jj - 1) = TextArray(kk)
79. Next kk
80. Dim insertionPoint(0 To 2) As Double, alignmentPoint(0 To 2) As Double
81.     'alignmentPoint(0) = 5: alignmentPoint(1) = 3: alignmentPoint(2) = 0
82. 'Dim tt As AcadText
83.     For ii = 1 To UBound(xx) - 1
84.       insertionPoint(1) = xx(ii) + 15
85.       insertionPoint(2) = 0
86.       For jj = 1 To UBound(yy) - 1
87.          insertionPoint(0) = yy(jj) + (yy(jj + 1) - yy(jj)) / 2
88.          
89.          alignmentPoint(0) = insertionPoint(0): alignmentPoint(1) = insertionPoint(1): alignmentPoint(2) = 0
90. 'Set pointObj = ThisDrawing.ModelSpace.AddPoint(alignmentPoint)
91.          'Debug.Print yy(jj), pp(0)
92.          'Debug.Print gg(ii-1, jj-1)
93.          Set tt = ThisDrawing.ModelSpace.AddText(Trim(gg(ii - 1, jj - 1)), insertionPoint, 18)
94.          With tt
95.            .StyleName = "WMF-宋体0"
96.            .HorizontalAlignment = acHorizontalAlignmentCenter
97.            .TextAlignmentPoint = alignmentPoint
98.            '.Alignment = acAlignmentCenter
99.            
101.          End With
102.       Next jj
103.     Next ii
104. End Sub
105. '冒泡程序
106. Function Bubble_Sort(Ary)
107.      Dim aryUBound, i, j
108.      aryUBound = UBound(Ary)
109.      For ii = 0 To aryUBound
110.        Ary(ii) = Val(Round(Ary(ii), 2))
111.      Next ii
112.      For i = 0 To aryUBound
113.        For j = i + 1 To aryUBound
114.          If Ary(i) > Ary(j) Then
115.            Swap Ary(i), Ary(j)
116.          End If
117.        Next
118.      Next
119.      Bubble_Sort = Ary
120. End Function
121. Function Swap(a, b)
122.      Dim tmp
123.      tmp = a
124.      a = b
125.      b = tmp
126. End Function

Function RemoveOverlap(ByRef Ary)                             On Error Resume Next                             Dim i     As Long                             Dim colTmp     As New Collection             For i = 0 To UBound(Ary) - 1                     colTmp.Add Ary(i), "K" & Ary(i)             Next                             Dim aryTmp()     As String             ReDim aryTmp(colTmp.Count - 1) As String             For i = 0 To colTmp.Count - 1                     aryTmp(i) = colTmp.Item(i + 1)             Next                             Set colTmp = Nothing             RemoveOverlap = aryTmp                     End Function '主程序 Sub ll()      Dim xm(1000) As Double, xm1(1000) As Double, TextArray(10000) As String, TextInsertPoint(10000, 2)      Dim tt As AcadText, ll As AcadLine, Ent As AcadEntity      xm_i = 0: xm1_i = 0: tt_i = 0      ''      Dim x1 As Double, y1 As Double      'ReDim xm(1000) As Double, xm1(1000) As Long      For Each Ent In ThisDrawing.ModelSpace        Select Case Ent.ObjectName          Case "AcDbLine"            Set ll = Ent            Select Case ll.Layer              Case "零件表格竖线"                'ReDim xm(xm_i) As Double                xm(xm_i) = Round(ll.EndPoint(0), 0)                'Debug.Print xm_i, xm(xm_i), Round(ll.EndPoint(0), 3)                xm_i = xm_i + 1              Case "零件表格横线"                'ReDim xm1(xm1_i) As Double                xm1(xm1_i) = Round(ll.EndPoint(1), 0)                xm1_i = xm1_i + 1            End Select          Case "AcDbText"            Set tt = Ent              If tt.Layer = "零件表格文本" Then                TextInsertPoint(tt_i, 0) = tt.insertionPoint(0)                TextInsertPoint(tt_i, 1) = tt.insertionPoint(1)                TextArray(tt_i) = tt.textString                tt_i = tt_i + 1              End If         End Select      Next Ent            MM = RemoveOverlap(xm1)      xx = Bubble_Sort(MM)            MM = RemoveOverlap(xm)      yy = Bubble_Sort(MM)      Dim gg      ReDim gg(UBound(xx) - 2, UBound(yy) - 2)       For kk = 0 To tt_i - 1     x1 = TextInsertPoint(kk, 1)     For ii = 1 To UBound(xx) - 1       If x1 > xx(ii) And x1 < xx(ii + 1) Then        Exit For       End If     Next ii y1 = Val(TextInsertPoint(kk, 0)) For jj = 1 To UBound(yy) - 1       If y1 > yy(jj) And y1 < yy(jj + 1) Then        Exit For       End If     Next jj     gg(ii - 1, jj - 1) = TextArray(kk) Next kk Dim insertionPoint(0 To 2) As Double, alignmentPoint(0 To 2) As Double     'alignmentPoint(0) = 5: alignmentPoint(1) = 3: alignmentPoint(2) = 0 'Dim tt As AcadText     For ii = 1 To UBound(xx) - 1       insertionPoint(1) = xx(ii) + 15       insertionPoint(2) = 0       For jj = 1 To UBound(yy) - 1          insertionPoint(0) = yy(jj) + (yy(jj + 1) - yy(jj)) / 2                    alignmentPoint(0) = insertionPoint(0): alignmentPoint(1) = insertionPoint(1): alignmentPoint(2) = 0 'Set pointObj = ThisDrawing.ModelSpace.AddPoint(alignmentPoint)          'Debug.Print yy(jj), pp(0)          'Debug.Print gg(ii-1, jj-1)          Set tt = ThisDrawing.ModelSpace.AddText(Trim(gg(ii - 1, jj - 1)), insertionPoint, 18)          With tt            .StyleName = "WMF-宋体0"            .HorizontalAlignment = acHorizontalAlignmentCenter            .TextAlignmentPoint = alignmentPoint            '.Alignment = acAlignmentCenter                      End With       Next jj     Next ii End Sub '冒泡程序 Function Bubble_Sort(Ary)      Dim aryUBound, i, j      aryUBound = UBound(Ary)      For ii = 0 To aryUBound        Ary(ii) = Val(Round(Ary(ii), 2))      Next ii      For i = 0 To aryUBound        For j = i + 1 To aryUBound          If Ary(i) > Ary(j) Then            Swap Ary(i), Ary(j)          End If        Next      Next      Bubble_Sort = Ary End Function Function Swap(a, b)      Dim tmp      tmp = a      a = b      b = tmp End Function

兰州人

另一种方法

2. Function RemoveOverlap(ByRef Ary)
3.               
4.            On Error Resume Next
5.               
6.            Dim i     As Long
7.               
8.            Dim colTmp     As New Collection
9.            For i = 0 To UBound(Ary) - 1
10.                    colTmp.Add Ary(i), "K" & Ary(i)
11.            Next
12.               
13.            Dim aryTmp()     As String
14.            ReDim aryTmp(colTmp.Count - 1) As String
15.            For i = 0 To colTmp.Count - 1
16.                    aryTmp(i) = colTmp.Item(i + 1)
17.            Next
18.               
19.            Set colTmp = Nothing
20.            RemoveOverlap = aryTmp
21.               
22.    End Function
23. '主程序
24. Sub ll()
25.     Dim xm(1000) As Double, xm1(1000) As Double, TextArray(10000) As String, TextInsertPoint(10000, 2)
26.     Dim tt As AcadText, ll As AcadLine, Ent As AcadEntity
27.     xm_i = 0: xm1_i = 0: tt_i = 0
28.     ''
29.     Dim x1 As Double, y1 As Double
30.     'ReDim xm(1000) As Double, xm1(1000) As Long
31.     For Each Ent In ThisDrawing.ModelSpace
32.       Select Case Ent.ObjectName
33.         Case "AcDbLine"
34.           Set ll = Ent
35.           Select Case ll.Layer
36.             Case "零件表格竖线"
37.               'ReDim xm(xm_i) As Double
38.               xm(xm_i) = Round(ll.EndPoint(0), 0)
39.               'Debug.Print xm_i, xm(xm_i), Round(ll.EndPoint(0), 3)
40.               xm_i = xm_i + 1
41.             Case "零件表格横线"
42.               'ReDim xm1(xm1_i) As Double
43.               xm1(xm1_i) = Round(ll.EndPoint(1), 0)
44.               xm1_i = xm1_i + 1
45.           End Select
46.         Case "AcDbText"
47.           Set tt = Ent
48.             If tt.Layer = "零件表格文本" Then
49.               TextInsertPoint(tt_i, 0) = tt.InsertionPoint(0)
50.               TextInsertPoint(tt_i, 1) = tt.InsertionPoint(1)
51.               TextArray(tt_i) = tt.TextString
52.               tt_i = tt_i + 1
53.             End If
54.        End Select
55.     Next Ent
56.    
57.     MM = RemoveOverlap(xm1)
58.     xx = Bubble_Sort(MM)
59.    
60.     MM = RemoveOverlap(xm)
61.     yy = Bubble_Sort(MM)
62.     Dim gg
63.     ReDim gg(UBound(xx) - 2, UBound(yy) - 2)
64.    
65. For kk = 0 To tt_i - 1
66.    x1 = TextInsertPoint(kk, 1)
67.    For ii = 1 To UBound(xx) - 1
68.      If x1 > xx(ii) And x1 < xx(ii + 1) Then
69.       Exit For
70.      End If
71.    Next ii
72. y1 = Val(TextInsertPoint(kk, 0))
73. For jj = 1 To UBound(yy) - 1
74.      If y1 > yy(jj) And y1 < yy(jj + 1) Then
75.       Exit For
76.      End If
77.    Next jj
78.    gg(ii - 1, jj - 1) = TextArray(kk)
79. Next kk
80. Dim pp(0 To 2) As Double
81. 'Dim tt As AcadText
82.    For ii = 1 To UBound(xx) - 1
83.      pp(1) = xx(ii) + 10
84.      For jj = 1 To UBound(yy) - 1
85.         pp(0) = yy(jj) + (yy(jj + 1) - yy(jj)) / 2
86.         Debug.Print yy(jj), pp(0)
87.         'Debug.Print gg(ii-1, jj-1)
88.         Set tt = ThisDrawing.ModelSpace.AddText(Trim(gg(ii - 1, jj - 1)), pp, 18)
89.      Next jj
90.    Next ii
91. End Sub
92. '冒泡程序
93. Function Bubble_Sort(Ary)
94.     Dim aryUBound, i, j
95.     aryUBound = UBound(Ary)
96.     For ii = 0 To aryUBound
97.       Ary(ii) = Val(Round(Ary(ii), 2))
98.     Next ii
99.     For i = 0 To aryUBound
100.       For j = i + 1 To aryUBound
101.         If Ary(i) > Ary(j) Then
102.           Swap Ary(i), Ary(j)
103.         End If
104.       Next
105.     Next
106.     Bubble_Sort = Ary
107. End Function
108. Function Swap(a, b)
109.     Dim tmp
110.     tmp = a
111.     a = b
112.     b = tmp
113. End Function

Function RemoveOverlap(ByRef Ary)                           On Error Resume Next                           Dim i     As Long                           Dim colTmp     As New Collection            For i = 0 To UBound(Ary) - 1                    colTmp.Add Ary(i), "K" & Ary(i)            Next                           Dim aryTmp()     As String            ReDim aryTmp(colTmp.Count - 1) As String            For i = 0 To colTmp.Count - 1                    aryTmp(i) = colTmp.Item(i + 1)            Next                           Set colTmp = Nothing            RemoveOverlap = aryTmp                   End Function '主程序 Sub ll()     Dim xm(1000) As Double, xm1(1000) As Double, TextArray(10000) As String, TextInsertPoint(10000, 2)     Dim tt As AcadText, ll As AcadLine, Ent As AcadEntity     xm_i = 0: xm1_i = 0: tt_i = 0     ''     Dim x1 As Double, y1 As Double     'ReDim xm(1000) As Double, xm1(1000) As Long     For Each Ent In ThisDrawing.ModelSpace       Select Case Ent.ObjectName         Case "AcDbLine"           Set ll = Ent           Select Case ll.Layer             Case "零件表格竖线"               'ReDim xm(xm_i) As Double               xm(xm_i) = Round(ll.EndPoint(0), 0)               'Debug.Print xm_i, xm(xm_i), Round(ll.EndPoint(0), 3)               xm_i = xm_i + 1             Case "零件表格横线"               'ReDim xm1(xm1_i) As Double               xm1(xm1_i) = Round(ll.EndPoint(1), 0)               xm1_i = xm1_i + 1           End Select         Case "AcDbText"           Set tt = Ent             If tt.Layer = "零件表格文本" Then               TextInsertPoint(tt_i, 0) = tt.InsertionPoint(0)               TextInsertPoint(tt_i, 1) = tt.InsertionPoint(1)               TextArray(tt_i) = tt.TextString               tt_i = tt_i + 1             End If        End Select     Next Ent         MM = RemoveOverlap(xm1)     xx = Bubble_Sort(MM)         MM = RemoveOverlap(xm)     yy = Bubble_Sort(MM)     Dim gg     ReDim gg(UBound(xx) - 2, UBound(yy) - 2)     For kk = 0 To tt_i - 1    x1 = TextInsertPoint(kk, 1)    For ii = 1 To UBound(xx) - 1      If x1 > xx(ii) And x1 < xx(ii + 1) Then       Exit For      End If    Next ii y1 = Val(TextInsertPoint(kk, 0)) For jj = 1 To UBound(yy) - 1      If y1 > yy(jj) And y1 < yy(jj + 1) Then       Exit For      End If    Next jj    gg(ii - 1, jj - 1) = TextArray(kk) Next kk Dim pp(0 To 2) As Double 'Dim tt As AcadText    For ii = 1 To UBound(xx) - 1      pp(1) = xx(ii) + 10      For jj = 1 To UBound(yy) - 1         pp(0) = yy(jj) + (yy(jj + 1) - yy(jj)) / 2         Debug.Print yy(jj), pp(0)         'Debug.Print gg(ii-1, jj-1)         Set tt = ThisDrawing.ModelSpace.AddText(Trim(gg(ii - 1, jj - 1)), pp, 18)      Next jj    Next ii End Sub '冒泡程序 Function Bubble_Sort(Ary)     Dim aryUBound, i, j     aryUBound = UBound(Ary)     For ii = 0 To aryUBound       Ary(ii) = Val(Round(Ary(ii), 2))     Next ii     For i = 0 To aryUBound       For j = i + 1 To aryUBound         If Ary(i) > Ary(j) Then           Swap Ary(i), Ary(j)         End If       Next     Next     Bubble_Sort = Ary End Function Function Swap(a, b)     Dim tmp     tmp = a     a = b     b = tmp End Function