|
|
发表于 2016-1-5 21:27:00
|
显示全部楼层
前面获取点的部分代码，后面的代码你自己接上吧
Sub tt()
On Error Resume Next
Dim ss As AcadSelectionSet
ThisDrawing.SelectionSets("TlsTest").Delete
Set ss = ThisDrawing.SelectionSets.Add("TlsTest")
Dim ft(0) As Integer, fd(0)
ft(0) = 0: fd(0) = "line"
ss.SelectOnScreen ft, fd
Dim pts()
Dim lines() As Collection
Dim id As Integer
Dim line As AcadLine
For i = 0 To ss.Count - 1
Set line = ss(i)
AddPoint pts, lines, line.StartPoint, line
AddPoint pts, lines, line.EndPoint, line
Next i
End Sub
Sub AddPoint(ByRef pts(), ByRef lines() As Collection, pt, line)
On Error Resume Next
Dim n As Integer
Dim id As Integer
n = UBound(pts)
If Err Then n = -1
For i = 0 To n
If (pts(i)(0) - pt(0)) ^ 2 + (pts(i)(1) - pt(1)) ^ 2 < 0.00000001 Then
lines(i).Add line
Exit Sub
End If
Next i
n = n + 1
ReDim Preserve pts(n)
ReDim Preserve lines(n)
pts(n) = pt
Set lines(n) = New Collection
lines(n).Add line
End Sub |
|
置顶卡
