雪山飞狐_lzh 发表于 2006-7-2 12:39:00

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

本帖最后由 作者 于 2006-7-3 7:28:41 编辑

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 发表于 2006-7-2 14:41:00

<FONT color=#0000ff>Dim</FONT> ss <FONT color=blue>As</FONT> <FONT color=blue>New</FONT> TlsSelectionSet, 2004CAD这一句通不过.

雪山飞狐_lzh 发表于 2006-7-2 14:50:00

<P><U><FONT color=#0000ff>需要TlsResultBuffer和TlsSelectSet类，在我的博客里下载：）</FONT></U></P>

tcsl9621 发表于 2006-7-3 10:08:00

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

zhuxuhong 发表于 2006-7-3 12:14:00

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

chman 发表于 2006-7-3 15:37:00

<P>要支持“line和pline”就好了</P>
<P>现在只能选择线段</P>
<P>未免有点可惜</P>

五福娃 发表于 2006-7-5 12:38:00

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

tcsl9621 发表于 2006-7-8 22:04:00

你可以这么实现，只选择一个直线，然后程序自动先择与此线某一端点相交的线段，连成多义线。后面的照此垫行。一定行。
页: [1]
查看完整版本: 示例:连接直线为优化多义线