示例:连接直线为优化多义线

雪山飞狐_lzh

2. Sub jline()
3.     Dim obj As AcadLine, pnt
4.     Dim objs As New Collection
5.     Dim selobj As AcadLine
6.     Dim pnts As New Collection
7.     Dim i, j
8.     ThisDrawing.Utility.GetEntity obj, pnt
9.     Dim ss As New TlsSelectionSet
10.     pnts.Add obj.StartPoint
11.     pnts.Add obj.EndPoint
12.     objs.Add obj
13.    
14.     '从选择线起点找起，一直到没有连接的直线或一个以上的直线为止
15.     Do While True
16.         ss.Init
17.         ss.Filter.SetData 0, "line", -4, "<or", 10, pnts(1), 11, pnts(1), -4, "or>"
18.         ss.SelectObject acSelectionSetAll
19.         If ss.Count = 2 Then
20.             If ss.Item(0) Is obj Then
21.                 Set obj = ss.Item(1)
22.             Else
23.                 Set obj = ss.Item(0)
24.             End If
25.             If isChild(objs, obj) Then Exit Do
26.             
27.             If obj.StartPoint(0) = pnts(1)(0) And obj.StartPoint(1) = pnts(1)(1) Then
28.                 pnts.Add obj.EndPoint, , 1
29.             Else
30.                 pnts.Add obj.StartPoint, , 1
31.             End If
32.             objs.Add obj, , 1
33.         Else
34.             Exit Do
35.         End If
36.     Loop
37.    
38.     '从选择线终点找起，一直到没有连接的直线或一个以上的直线为止
39.     Set obj = selobj
40.     Do While True
41.         ss.Init
42.         ss.Filter.SetData 0, "line", -4, "<or", 10, pnts(pnts.Count), 11, pnts(pnts.Count), -4, "or>"
43.         ss.SelectObject acSelectionSetAll
44.         If ss.Count = 2 Then
45.             If ss.Item(0) Is obj Then
46.                 Set obj = ss.Item(1)
47.             Else
48.                 Set obj = ss.Item(0)
49.             End If
50.             If isChild(objs, obj) Then Exit Do
51.             
52.             If obj.StartPoint(0) = pnts(pnts.Count)(0) And obj.StartPoint(1) = pnts(pnts.Count)(1) Then
53.                 pnts.Add obj.EndPoint
54.             Else
55.                 pnts.Add obj.StartPoint
56.             End If
57.             objs.Add obj
58.         Else
59.             Exit Do
60.         End If
61.     Loop
62.     Dim dots() As Double
63.     ReDim dots(pnts.Count * 2 - 1)
64.     For i = 1 To pnts.Count
65.         For j = 0 To 1
66.             dots((i - 1) * 2 + j) = pnts(i)(j)
67.         Next
68.     Next
69.     ThisDrawing.ModelSpace.AddLightWeightPolyline dots
70.     For Each i In objs
71.         i.Delete
72.     Next i
73. End Sub
75. Function isChild(objs As Variant, obj As Object)
76. Dim i
77. For Each i In objs
78.     If i Is obj Then isChild = True: Exit For
79. Next
80. End Function

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

cqy

Dim ss As New TlsSelectionSet, 2004CAD这一句通不过.

雪山飞狐_lzh

需要TlsResultBuffer和TlsSelectSet类，在我的博客里下载：）

tcsl9621

楼主，好样的。我正需要这个。我以前用LISP编了个将选定的直线和圆弧连成多义线的程序。楼主用VBA实现真是太好了。呵……我现在改用VB.net了。

zhuxuhong

楼主,能否改为批量选择,自动连接?如果图面有大量直线,这么逐个选取不是太麻烦了.

chman

要支持“line和pline”就好了

现在只能选择线段

未免有点可惜

五福娃

我没弄懂  下下来的类怎么用啊 我是刚学的请高人指教啊 先谢谢了

tcsl9621

你可以这么实现，只选择一个直线，然后程序自动先择与此线某一端点相交的线段，连成多义线。后面的照此垫行。一定行。