合并一根直线上的两根线段

mikewolf2k 发表于 2004-2-12 19:13:00

本帖最后由作者于 2004-2-16 19:06:11 编辑 Sub uniteline() Dim returnobj As AcadEntity, basepnt As Variant, pnt1 As Variant, pnt2 As Variant, pnt3 As Variant, pnt4 As Variant Dim line1 As Variant, line2 As Variant choose1: ActiveDocument.Utility.GetEntity returnobj, basepnt, "选择第一根线段:" Select Case returnobj.ObjectName Case "AcDbLine" '第一根为line Set line1 = returnobj pnt1 = line1.StartPoint: pnt2 = line1.EndPoint Case "AcDbPolyline" '第一根为lwpolyline Set line1 = returnobj If line1.Area > 0.000001 Then '判断是否为直线 ActiveDocument.Utility.Prompt "您选择的不是一根线段,请重新选择" GoTo choose1 Else End If pnt1 = basepnt pnt2 = basepnt basepnt = line1.Coordinates pnt1(0) = basepnt(0): pnt1(1) = basepnt(1) pnt2(0) = basepnt(2): pnt2(1) = basepnt(3) If pnt1(0) = pnt2(0) Then '垂直 For i = 1 To (UBound(basepnt) + 1) / 2 If pnt1(1) > basepnt(2 * i - 1) Then pnt1(1) = basepnt(2 * i - 1) If pnt2(1) < basepnt(2 * i - 1) Then pnt2(1) = basepnt(2 * i - 1) Next i Else '不垂直 For i = 1 To (UBound(basepnt) + 1) / 2 If pnt1(0) > basepnt(2 * i - 2) Then pnt1(0) = basepnt(2 * i - 2) pnt1(1) = basepnt(2 * i - 1) Else End If If pnt2(0) < basepnt(2 * i - 2) Then pnt2(0) = basepnt(2 * i - 2) pnt2(1) = basepnt(2 * i - 1) Else End If Next i End If Case Else ActiveDocument.Utility.Prompt "您选择的不是一根线段,请重新选择" GoTo choose1 End Select choose2: ActiveDocument.Utility.GetEntity returnobj, basepnt, "选择第二根线段:" If returnobj.Handle = line1.Handle Then ActiveDocument.Utility.Prompt "线段二与线段一重复,请重新选择" GoTo choose2 Else End If Select Case returnobj.ObjectName Case "AcDbLine" '第二根为line Set line2 = returnobj pnt3 = line2.StartPoint: pnt4 = line2.EndPoint Case "AcDbPolyline" '第二根为lwpolyline Set line2 = returnobj If line2.Area > 0.000001 Then '判断是否为直线 ActiveDocument.Utility.Prompt "您选择的不是一根线段,请重新选择" GoTo choose2 Else End If pnt3 = basepnt pnt4 = basepnt basepnt = line2.Coordinates pnt3(0) = basepnt(0): pnt3(1) = basepnt(1) pnt4(0) = basepnt(2): pnt4(1) = basepnt(3) If pnt3(0) = pnt4(0) Then '垂直 For i = 1 To (UBound(basepnt) + 1) / 2 If pnt3(1) > basepnt(2 * i - 1) Then pnt3(1) = basepnt(2 * i - 1) If pnt4(1) < basepnt(2 * i - 1) Then pnt4(1) = basepnt(2 * i - 1) Next i Else '不垂直 For i = 1 To (UBound(basepnt) + 1) / 2 If pnt3(0) > basepnt(2 * i - 2) Then pnt3(0) = basepnt(2 * i - 2) pnt3(1) = basepnt(2 * i - 1) Else End If If pnt4(0) < basepnt(2 * i - 2) Then pnt4(0) = basepnt(2 * i - 2) pnt4(1) = basepnt(2 * i - 1) Else End If Next i End If Case Else ActiveDocument.Utility.Prompt "您选择的不是一根线段,请重新选择" GoTo choose2 End Select If pnt2(0) = pnt1(0) Then '垂直 If (pnt2(0) = pnt3(0)) And (pnt3(0) = pnt4(0)) Then If pnt1(1) > pnt2(1) Then basepnt = pnt1: pnt1 = pnt2: pnt2 = basepnt End If If pnt1(1) > pnt3(1) Then basepnt = pnt1: pnt1 = pnt3: pnt3 = basepnt End If If pnt1(1) > pnt4(1) Then basepnt = pnt1: pnt1 = pnt4: pnt4 = basepnt End If If pnt4(1) < pnt2(1) Then basepnt = pnt4: pnt4 = pnt2: pnt2 = basepnt End If If pnt4(1) < pnt3(1) Then basepnt = pnt4: pnt4 = pnt3: pnt3 = basepnt End If GoTo unite '合并 Else ActiveDocument.Utility.Prompt "线段一与线段二不在同一直线上,无法合并." End If Else '不垂直 If pnt1(0) > pnt2(0) Then basepnt = pnt1: pnt1 = pnt2: pnt2 = basepnt End If If pnt1(0) > pnt3(0) Then basepnt = pnt1: pnt1 = pnt3: pnt3 = basepnt End If If pnt1(0) > pnt4(0) Then basepnt = pnt1: pnt1 = pnt4: pnt4 = basepnt End If If pnt4(0) < pnt2(0) Then basepnt = pnt4: pnt4 = pnt2: pnt2 = basepnt End If If pnt4(0) < pnt3(0) Then basepnt = pnt4: pnt4 = pnt3: pnt3 = basepnt End If If (Abs((pnt3(1) - pnt1(1)) * (pnt2(0) - pnt1(0)) - (pnt3(0) - pnt1(0)) * (pnt2(1) - pnt1(1))) + Abs((pnt4(1) - pnt1(1)) * (pnt2(0) - pnt1(0)) - (pnt4(0) - pnt1(0)) * (pnt2(1) - pnt1(1)))) < 0.000001 Then GoTo unite '合并 Else ActiveDocument.Utility.Prompt "线段一与线段二不在同一直线上,无法合并." End If End If End unite: Select Case line1.ObjectName Case "AcDbLine" line1.StartPoint = pnt1: line1.EndPoint = pnt4 line2.Delete ActiveDocument.Utility.Prompt "线段一与线段二已合并." Case "AcDbPolyline"

Do While UBound(line1.Coordinates) > 4 '新增 pnt2 = line1.Coordinates For i = 1 To (UBound(pnt2) - 2) ReDim basepnt(0 To (UBound(pnt2) - 2)) basepnt(i) = pnt2(i) Next i line1.Coordinates = basepnt Loop '新增 ReDim basepnt(0 To 3) basepnt(0) = pnt1(0): basepnt(1) = pnt1(1) basepnt(2) = pnt4(0): basepnt(3) = pnt4(1) line1.Coordinates = basepnt line2.Delete ActiveDocument.Utility.Prompt "线段一与线段二已合并." Case Else End Select End Sub

vladimirputin 发表于 2016-10-19 16:33:39

楼主的程序真是太好了，正需要的啊。

jdzhqddzh 发表于 2020-8-5 17:58:34

谢谢众位坛友代码分享！

mikewolf2k 发表于 2004-2-12 19:18:00

本程序可以合并同一直线上的两根线段,可以使line和polyline, 合并后的线段属性同第一根线段.

还可以跟完善一些,比如选择线段是可以通过框选等.哪位高手能否提供框选方法,不胜感激!

yfy2003 发表于 2004-2-12 19:54:00

好程序！

先谢！

无痕发表于 2004-2-13 12:55:00

好像不用写这么长吧？

mikewolf2k 发表于 2004-2-13 19:27:00

少是可以少几行,但我认为没什么意义.我选取的可以是line也可以是polyline,如果高手有更好的算法请赐教,谢谢.

mccad 发表于 2004-2-13 19:55:00

choose1和choose2可以写成一个单独的函数，因为内容是一样的。如以下函数，除可取得图元外，同样把图元的两个端点均取得，而且端点已经进行了排序，这样可以更方便，也更清晰。Function GetLine(PromptTxt As String, ByRef Point1 As Variant, ByRef Point2 As Variant) As AcadEntity
Dim ent As AcadEntity
   Dim pnt As Variant
   Dim p1(2) As Double
   Dim p2(2) As Double
   On Error Resume Next
   ThisDrawing.Utility.GetEntity ent, pnt, PromptTxt
   Do
            Select Case ent.ObjectName
                  Case "AcDbLine"
                           Set GetLine = ent
                           Point1 = ent.StartPoint
                           Point2 = ent.EndPoint
                           If ThisDrawing.Utility.AngleFromXAxis(Point1, Point2) >= PI Then
                                    Point1 = ent.EndPoint
                                    Point2 = ent.StartPoint
                           End If
                           Exit Do
                  Case "AcDbPolyline"
                           If UBound(ent.Coordinates) = 3 Then
                                    p1(0) = ent.Coordinates(0): p1(1) = ent.Coordinates(1)
                                    p2(0) = ent.Coordinates(2): p2(1) = ent.Coordinates(3)
                                    If ThisDrawing.Utility.AngleFromXAxis(p1, p2) >= PI Then
                                          p2(0) = ent.Coordinates(0): p2(1) = ent.Coordinates(1)
                                          p1(0) = ent.Coordinates(2): p1(1) = ent.Coordinates(3)
                                    End If
                                    Set GetLine = ent
                                    Point1 = p1: Point2 = p2
                                    Exit Do
                           End If
            End Select
            ThisDrawing.Utility.Prompt vbCr & "所选对象不符合要求,请重新"
   Loop
End Function

Public Function PI() As Double
PI = Atn(1) * 4
End Function另外，为什么要判断是否垂直，其它对于线来说，如第1条线是P1和P2点，第2条线是P3和P4点，这样如果第1线与第2线的角度是一样，而且第1线的角度与P1P3点的角度一样的话，则可判断两条线是在同一线上。
这样的话，就剩下4个点的排序了，因为两组点已经排好序，所以也就简单。

mikewolf2k 发表于 2004-2-13 20:29:00

判断垂直是为了按y值排序,否则按x值排序,总之p1,p4分别为最外侧的两个点.

如果四个点分别为p1(1,0),p2(2,0),p3(3,0),p4(3,1),那么p1p2角度等于p1p3角度,但是他们不在同一直线上.

对于polyline,可能不只两个端点,多端点的情况也要考虑.

choose1和choose2是可以合并,但要另外写一个函数,我不想这么做,整个功能写在一个sub内,看起来方便.

无痕发表于 2004-2-14 10:53:00

好像对pl只是支持仅有两个端点的pl，未免有些遗憾。

mikewolf2k 发表于 2004-2-14 18:58:00

不是呀,只要是同一直线上的pl,多少端点都可以,你可以试试嘛.

无痕发表于 2004-2-15 05:43:00

我测试的时候是不行的，当pl有多个交点的时候

页: [1] 2 3

明经CAD社区's Archiver

合并一根直线上的两根线段