- UID
- 76071
- 积分
- 1505
- 精华
- 贡献
-
- 威望
-
- 活跃度
-
- D豆
-
- 在线时间
- 小时
- 注册时间
- 2003-8-30
- 最后登录
- 1970-1-1
|
马上注册,结交更多好友,享用更多功能,让你轻松玩转社区。
您需要 登录 才可以下载或查看,没有账号?立即注册
×
[php]
Sub jline()
Dim obj As AcadLine, pnt
Dim objs As New Collection
Dim selobj As AcadLine
Dim pnts As New Collection
Dim i, j
ThisDrawing.Utility.GetEntity obj, pnt
Dim ss As New TlsSelectionSet
pnts.Add obj.StartPoint
pnts.Add obj.EndPoint
objs.Add obj
'从选择线起点找起,一直到没有连接的直线或一个以上的直线为止
Do While True
ss.Init
ss.Filter.SetData 0, "line", -4, "<or", 10, pnts(1), 11, pnts(1), -4, "or>"
ss.SelectObject acSelectionSetAll
If ss.Count = 2 Then
If ss.Item(0) Is obj Then
Set obj = ss.Item(1)
Else
Set obj = ss.Item(0)
End If
If isChild(objs, obj) Then Exit Do
If obj.StartPoint(0) = pnts(1)(0) And obj.StartPoint(1) = pnts(1)(1) Then
pnts.Add obj.EndPoint, , 1
Else
pnts.Add obj.StartPoint, , 1
End If
objs.Add obj, , 1
Else
Exit Do
End If
Loop
'从选择线终点找起,一直到没有连接的直线或一个以上的直线为止
Set obj = selobj
Do While True
ss.Init
ss.Filter.SetData 0, "line", -4, "<or", 10, pnts(pnts.Count), 11, pnts(pnts.Count), -4, "or>"
ss.SelectObject acSelectionSetAll
If ss.Count = 2 Then
If ss.Item(0) Is obj Then
Set obj = ss.Item(1)
Else
Set obj = ss.Item(0)
End If
If isChild(objs, obj) Then Exit Do
If obj.StartPoint(0) = pnts(pnts.Count)(0) And obj.StartPoint(1) = pnts(pnts.Count)(1) Then
pnts.Add obj.EndPoint
Else
pnts.Add obj.StartPoint
End If
objs.Add obj
Else
Exit Do
End If
Loop
Dim dots() As Double
ReDim dots(pnts.Count * 2 - 1)
For i = 1 To pnts.Count
For j = 0 To 1
dots((i - 1) * 2 + j) = pnts(i)(j)
Next
Next
ThisDrawing.ModelSpace.AddLightWeightPolyline dots
For Each i In objs
i.Delete
Next i
End Sub
Function isChild(objs As Variant, obj As Object)
Dim i
For Each i In objs
If i Is obj Then isChild = True: Exit For
Next
End Function
[/php] |
|