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

mikewolf2k

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

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

jdzhqddzh

谢谢众位坛友代码分享！

mikewolf2k

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


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

yfy2003

好程序！


先谢！

无痕

好像不用写这么长吧？

mikewolf2k

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

mccad

choose1和choose2可以写成一个单独的函数，因为内容是一样的。如以下函数，除可取得图元外，同样把图元的两个端点均取得，而且端点已经进行了排序，这样可以更方便，也更清晰。

2.   Function GetLine(PromptTxt As String, ByRef Point1 As Variant, ByRef Point2 As Variant) As AcadEntity
3.      Dim ent As AcadEntity
4.        Dim pnt As Variant
5.        Dim p1(2) As Double
6.        Dim p2(2) As Double
7.        On Error Resume Next
8.        ThisDrawing.Utility.GetEntity ent, pnt, PromptTxt
9.        Do
10.                Select Case ent.ObjectName
11.                        Case "AcDbLine"
12.                                Set GetLine = ent
13.                                Point1 = ent.StartPoint
14.                                Point2 = ent.EndPoint
15.                                If ThisDrawing.Utility.AngleFromXAxis(Point1, Point2) >= PI Then
16.                                        Point1 = ent.EndPoint
17.                                        Point2 = ent.StartPoint
18.                                End If
19.                                Exit Do
20.                        Case "AcDbPolyline"
21.                                If UBound(ent.Coordinates) = 3 Then
22.                                        p1(0) = ent.Coordinates(0): p1(1) = ent.Coordinates(1)
23.                                        p2(0) = ent.Coordinates(2): p2(1) = ent.Coordinates(3)
24.                                        If ThisDrawing.Utility.AngleFromXAxis(p1, p2) >= PI Then
25.                                                p2(0) = ent.Coordinates(0): p2(1) = ent.Coordinates(1)
26.                                                p1(0) = ent.Coordinates(2): p1(1) = ent.Coordinates(3)
27.                                        End If
28.                                        Set GetLine = ent
29.                                        Point1 = p1: Point2 = p2
30.                                        Exit Do
31.                                End If
32.                End Select
33.                ThisDrawing.Utility.Prompt vbCr & "所选对象不符合要求,请重新"
34.        Loop                       
35. End Function
37. Public Function PI() As Double
38.    PI = Atn(1) * 4
39. End Function

  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

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


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


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


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

无痕

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

mikewolf2k

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

无痕

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