[原创]Line的startpoint(0)和(1)的不重复排序
本帖最后由 作者 于 2008-5-21 23:43:28 编辑在做材料表时将其表格线按不重复排序进行处理。
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
本帖最后由 作者 于 2008-5-21 22:36:01 编辑
另一种方法
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
页:
[1]