通过框选连接线的ｖｂａ程序

subtlation · 发表于 2004-2-16 21:06:00

uniteSS为框选。uniteline为一根一根选择（只能选择两根）。对多段线和直线都有效。

复制代码

Sub uniteSS()
'On Error Resume Next
Dim ssetObj As AcadSelectionSet
Set ssetObj = CreateSelectionSet("uniteSS")
Dim fType, fData
BuildFilter fType, fData, -4, "<or", 0, "line", 0, "LWPolyline", -4, "or>"
'屏选直线或多段线
ssetObj.SelectOnScreen fType, fData
Dim i As Integer
If ssetObj.Count <= 1 Then
ThisDrawing.Utility.Prompt "选择的线少于两个，退出命令。"
Exit Sub
End If
Dim line1 As Object
Dim line2 As Object
Set line1 = ssetObj(0)
Dim pd As Boolean
For i = 1 To ssetObj.Count
Set line2 = ssetObj(i)
'连接线
pd = unite2Line(line1, line2)
'如果连接不成功，则退出命令。
If Not pd Then ssetObj.Delete: Exit Sub
Next
ssetObj.Delete
End Sub

Sub uniteline()
On Error Resume Next
'取得线
Dim line1 As Object
Dim line2 As Object
Dim pt1, pt2, pt3, pt4, basePnt As AcadEntity
Dim lpt1, lpt2 As Variant
gwGetEntity line1, basePnt, "请选择第一根直线或多段线：", "AcDbLine", "AcDbPolyline"
If line1 Is Nothing Then
ThisDrawing.Utility.Prompt "用户取消，退出命令。"
Exit Sub
End If
gwGetEntity line2, basePnt, "请选择第二根直线或多段线：", "AcDbLine", "AcDbPolyline"
If line2 Is Nothing Then
ThisDrawing.Utility.Prompt "用户取消，退出命令。"
Exit Sub
End If
'连接线
unite2Line line1, line2
End Sub

Function unite2Line(ByRef line1 As Object, ByVal line2 As Object) As Boolean
'连接线函数，连接后的线返回到变量line1中，如果连接成功，unite2Line返回true，否则为false
On Error Resume Next
unite2Line = False
If line1.Handle = line2.Handle Then
ThisDrawing.Utility.Prompt "选择的是同一直线或多段线，退出命令。"
Exit Function
End If
getLinePoint line1, pt1, pt2
getLinePoint line2, pt3, pt4
Dim A1, A2, A3 As Double
Dim maxdi As Double
A1 = ThisDrawing.Utility.AngleFromXAxis(pt1, pt2)
A2 = ThisDrawing.Utility.AngleFromXAxis(pt3, pt4)
A3 = ThisDrawing.Utility.AngleFromXAxis(pt1, pt3)
'判断四点是否共线
If Abs(A1 - A2) < 0.0000001 And (Abs(A1 - A3) < 0.0000001 Or Abs(Abs(A1 - A3) - PI) < 0.0000001) Then
'取得距离最远的两个点。
maxdi = MaxDouble(GetDistance(pt1, pt2), GetDistance(pt1, pt3), GetDistance(pt1, pt4), _
GetDistance(pt2, pt3), GetDistance(pt2, pt4), GetDistance(pt3, pt4))
If GetDistance(pt1, pt2) = maxdi Then lpt1 = pt1: lpt2 = pt2
If GetDistance(pt1, pt3) = maxdi Then lpt1 = pt1: lpt2 = pt3
If GetDistance(pt1, pt4) = maxdi Then lpt1 = pt1: lpt2 = pt4
If GetDistance(pt2, pt3) = maxdi Then lpt1 = pt2: lpt2 = pt3
If GetDistance(pt2, pt4) = maxdi Then lpt1 = pt2: lpt2 = pt4
If GetDistance(pt3, pt4) = maxdi Then lpt1 = pt3: lpt2 = pt4
'画直线
Select Case line1.ObjectName
Case "AcDbLine"
line1.StartPoint = lpt1
line1.EndPoint = lpt2
line2.Delete
ThisDrawing.Utility.Prompt "线段已连接为直线．"
unite2Line = True
Case "AcDbPolyline"
Dim newPline As AcadLWPolyline
Set newPline = AddLWPlineSeg(lpt1, lpt2, line1.ConstantWidth)
newPline.Layer = line1.Layer
newPline.color = line1.color
newPline.Linetype = line1.Linetype
line1.Delete
line2.Delete
Set line1 = newPline
ThisDrawing.Utility.Prompt "线段已连接为多段线．"
unite2Line = True
End Select
Else: ThisDrawing.Utility.Prompt "两线不在同一直线上，退出命令．"
End If
End Function

Function unite2Line(ByRef line1 As Object, ByVal line2 As Object) As Boolean
   '连接线函数，连接后的线返回到变量line1中，如果连接成功，unite2Line返回true，否则为false
   On Error Resume Next
   unite2Line = False
   
   If line1.Handle = line2.Handle Then
       ThisDrawing.Utility.Prompt "选择的是同一直线或多段线，退出命令。"
       Exit Function
   End If
   
   getLinePoint line1, pt1, pt2
   getLinePoint line2, pt3, pt4
   
   Dim A1, A2, A3 As Double
   Dim maxdi As Double
   A1 = ThisDrawing.Utility.AngleFromXAxis(pt1, pt2)
   A2 = ThisDrawing.Utility.AngleFromXAxis(pt3, pt4)
   A3 = ThisDrawing.Utility.AngleFromXAxis(pt1, pt3)
   '判断四点是否共线
   If Abs(A1 - A2) < 0.0000001 And (Abs(A1 - A3) < 0.0000001 Or Abs(Abs(A1 - A3) - PI) < 0.0000001) Then
           '取得距离最远的两个点。
           maxdi = MaxDouble(GetDistance(pt1, pt2), GetDistance(pt1, pt3), GetDistance(pt1, pt4), _
                                               GetDistance(pt2, pt3), GetDistance(pt2, pt4), GetDistance(pt3, pt4))
           If GetDistance(pt1, pt2) = maxdi Then lpt1 = pt1: lpt2 = pt2
           If GetDistance(pt1, pt3) = maxdi Then lpt1 = pt1: lpt2 = pt3
           If GetDistance(pt1, pt4) = maxdi Then lpt1 = pt1: lpt2 = pt4
           If GetDistance(pt2, pt3) = maxdi Then lpt1 = pt2: lpt2 = pt3
           If GetDistance(pt2, pt4) = maxdi Then lpt1 = pt2: lpt2 = pt4
           If GetDistance(pt3, pt4) = maxdi Then lpt1 = pt3: lpt2 = pt4
           '画直线
           Select Case line1.ObjectName
                 Case "AcDbLine"
                     line1.StartPoint = lpt1
                     line1.EndPoint = lpt2
                     line2.Delete
                     ThisDrawing.Utility.Prompt "线段已连接为直线．"
                     unite2Line = True
                 Case "AcDbPolyline"
                     Dim newPline As AcadLWPolyline
                     Set newPline = AddLWPlineSeg(lpt1, lpt2, line1.ConstantWidth)
                     newPline.Layer = line1.Layer
                     newPline.color = line1.color
                     newPline.Linetype = line1.Linetype
                     line1.Delete
                     line2.Delete
                     Set line1 = newPline
                     ThisDrawing.Utility.Prompt "线段已连接为多段线．"
                     unite2Line = True
           End Select
   Else: ThisDrawing.Utility.Prompt "两线不在同一直线上，退出命令．"
   End If
End Function

subtlation · 发表于 2004-2-16 21:08:00

以下是上述代码调用的函数。

'创建轻量多段线（只有两个顶点的直线多段线）
Public Function AddLWPlineSeg(ByVal ptSt As Variant, ByVal ptEn As Variant, Optional ByVal width As Double = 0) As AcadLWPolyline
Dim objPline As AcadLWPolyline
Dim ptArr(0 To 3) As Double
ptArr(0) = ptSt(0)
ptArr(1) = ptSt(1)
ptArr(2) = ptEn(0)
ptArr(3) = ptEn(1)
Set objPline = ThisDrawing.ModelSpace.AddLightWeightPolyline(ptArr)
objPline.ConstantWidth = width
objPline.Update
Set AddLWPlineSeg = objPline
End Function
Public Function getLinePoint(ent As AcadEntity, ByRef Point1 As Variant, ByRef Point2 As Variant)
'本函数得到线的端点，其中point1为Ｙ坐标较小的点
Dim p1(2) As Double
Dim p2(2) As Double
Dim k As Integer
On Error Resume Next
Select Case ent.ObjectName
Case "AcDbLine"
Point1 = ent.StartPoint
Point2 = ent.EndPoint
If ThisDrawing.Utility.AngleFromXAxis(Point1, Point2) >= PI Then
Point1 = ent.EndPoint
Point2 = ent.StartPoint
End If
Case "AcDbPolyline"
Dim entCo As Variant
entCo = ent.Coordinates
k = UBound(entCo)
If k >= 3 Then
p1(0) = entCo(0): p1(1) = entCo(1)
p2(0) = entCo(k - 1): p2(1) = entCo(k)
If ThisDrawing.Utility.AngleFromXAxis(p1, p2) >= PI Then
p2(0) = entCo(0): p2(1) = entCo(1)
p1(0) = entCo(k - 1): p1(1) = entCo(k)
End If
Point1 = p1: Point2 = p2
End If
End Select
End Function
Public Function PI() As Double
PI = Atn(1) * 4
End Function
Public Sub GetEntityEx(ent As Object, pickedPoint, Optional Prompt)
'选择实体，直到用户取消操作
On Error Resume Next
StartLoop:
ThisDrawing.Utility.GetEntity ent, pt, Prompt
If Err Then
If ThisDrawing.GetVariable("errno") = 7 Then
Err.Clear
GoTo StartLoop
Else
Err.Raise vbObjectError + 5, , "用户取消操作"
End If
End If
End Sub
Public Sub gwGetEntity(ent As Object, pickedPoint, Prompt As String, ParamArray gType())
'选择某一类型的实体，如果选择错误则继续，按ESC退出
'gtype是实体名称，不区分大小写，可以用通配符号，如"AcDbBlockReference"，"acdb*text"等
Dim i As Integer
Dim pd As Boolean
pd = False
Do
GetEntityEx ent, pickedPoint, Prompt
If ent Is Nothing Then
Exit Do
ElseIf UBound(gType) - LBound(gType) + 1 = 0 Then
Exit Do
Else
For i = LBound(gType) To UBound(gType)
If UCase(ent.ObjectName) Like UCase(gType(i)) Then
Exit Do
Else
pd = True
End If
Next i
If pd Then ThisDrawing.Utility.Prompt "选择的实体不符合要求．"
End If
Loop
End Sub
'计算两点之间距离
Public Function GetDistance(sp As Variant, ep As Variant) As Double
Dim x As Double
Dim y As Double
Dim z As Double
x = sp(0) - ep(0)
y = sp(1) - ep(1)
z = sp(2) - ep(2)
GetDistance = Sqr((x ^ 2) + (y ^ 2) + (z ^ 2))
End Function
'返回两个Double类型变量的最大值
Public Function MaxDouble(ByVal a As Double, ParamArray b()) As Double
MaxDouble = a
Dim i As Integer
For i = LBound(b) To UBound(b)
If b(i) > MaxDouble Then MaxDouble = b(i)
Next i
End Function
Public Function CreateSelectionSet(Optional ssName As String = "ss") As AcadSelectionSet
'返回一个空白选择集
Dim ss As AcadSelectionSet
On Error Resume Next
Set ss = ThisDrawing.SelectionSets(ssName)
If Err Then Set ss = ThisDrawing.SelectionSets.Add(ssName)
ss.Clear
Set CreateSelectionSet = ss
End Function
Public Sub BuildFilter(typeArray, dataArray, ParamArray gCodes())
'用数组方式填充一对变量以用作为选择集过滤器使用
Dim fType() As Integer, fData()
Dim index As Long, i As Long
index = LBound(gCodes) - 1
For i = LBound(gCodes) To UBound(gCodes) Step 2
index = index + 1
ReDim Preserve fType(0 To index)
ReDim Preserve fData(0 To index)
fType(index) = CInt(gCodes(i))
fData(index) = gCodes(i + 1)
Next
typeArray = fType: dataArray = fData
End Sub

'创建轻量多段线（只有两个顶点的直线多段线）
Public Function AddLWPlineSeg(ByVal ptSt As Variant, ByVal ptEn As Variant, Optional ByVal width As Double = 0) As AcadLWPolyline
       Dim objPline As AcadLWPolyline
       Dim ptArr(0 To 3) As Double
       
       ptArr(0) = ptSt(0)
       ptArr(1) = ptSt(1)
       ptArr(2) = ptEn(0)
       ptArr(3) = ptEn(1)
       
       Set objPline = ThisDrawing.ModelSpace.AddLightWeightPolyline(ptArr)
       objPline.ConstantWidth = width
       objPline.Update
       Set AddLWPlineSeg = objPline
End Function
Public Function getLinePoint(ent As AcadEntity, ByRef Point1 As Variant, ByRef Point2 As Variant)
         '本函数得到线的端点，其中point1为Ｙ坐标较小的点
       Dim p1(2) As Double
       Dim p2(2) As Double
       Dim k As Integer
       On Error Resume Next
               Select Case ent.ObjectName
                       Case "AcDbLine"
                               Point1 = ent.StartPoint
                               Point2 = ent.EndPoint
                               If ThisDrawing.Utility.AngleFromXAxis(Point1, Point2) >= PI Then
                                       Point1 = ent.EndPoint
                                       Point2 = ent.StartPoint
                               End If
                       Case "AcDbPolyline"
                               Dim entCo As Variant
                               entCo = ent.Coordinates
                               k = UBound(entCo)
                               If k >= 3 Then
                                       p1(0) = entCo(0): p1(1) = entCo(1)
                                       p2(0) = entCo(k - 1): p2(1) = entCo(k)
                                       If ThisDrawing.Utility.AngleFromXAxis(p1, p2) >= PI Then
                                               p2(0) = entCo(0): p2(1) = entCo(1)
                                               p1(0) = entCo(k - 1): p1(1) = entCo(k)
                                       End If
                                       Point1 = p1: Point2 = p2
                               End If
               End Select
End Function
Public Function PI() As Double
   PI = Atn(1) * 4
End Function
Public Sub GetEntityEx(ent As Object, pickedPoint, Optional Prompt)
   '选择实体，直到用户取消操作
       On Error Resume Next
StartLoop:
       ThisDrawing.Utility.GetEntity ent, pt, Prompt
       If Err Then
               If ThisDrawing.GetVariable("errno") = 7 Then
                       Err.Clear
                       GoTo StartLoop
               Else
                       Err.Raise vbObjectError + 5, , "用户取消操作"
               End If
       End If
End Sub
Public Sub gwGetEntity(ent As Object, pickedPoint, Prompt As String, ParamArray gType())
  '选择某一类型的实体，如果选择错误则继续，按ESC退出
  'gtype是实体名称，不区分大小写，可以用通配符号，如"AcDbBlockReference"，"acdb*text"等
  Dim i As Integer
  Dim pd As Boolean
  pd = False
  Do
   GetEntityEx ent, pickedPoint, Prompt
   
   If ent Is Nothing Then
       Exit Do
   ElseIf UBound(gType) - LBound(gType) + 1 = 0 Then
       Exit Do
   Else
       For i = LBound(gType) To UBound(gType)
           If UCase(ent.ObjectName) Like UCase(gType(i)) Then
               Exit Do
           Else
               pd = True
           End If
       Next i
       If pd Then ThisDrawing.Utility.Prompt "选择的实体不符合要求．"
   End If
  Loop
  
End Sub
'计算两点之间距离
Public Function GetDistance(sp As Variant, ep As Variant) As Double
       Dim x As Double
       Dim y As Double
       Dim z As Double
       
       x = sp(0) - ep(0)
       y = sp(1) - ep(1)
       z = sp(2) - ep(2)
       
       GetDistance = Sqr((x ^ 2) + (y ^ 2) + (z ^ 2))
End Function
'返回两个Double类型变量的最大值
Public Function MaxDouble(ByVal a As Double, ParamArray b()) As Double
   MaxDouble = a
   Dim i As Integer
   For i = LBound(b) To UBound(b)
       If b(i) > MaxDouble Then MaxDouble = b(i)
   Next i
End Function
Public Function CreateSelectionSet(Optional ssName As String = "ss") As AcadSelectionSet
   '返回一个空白选择集
   
       Dim ss As AcadSelectionSet
       
       On Error Resume Next
       Set ss = ThisDrawing.SelectionSets(ssName)
       If Err Then Set ss = ThisDrawing.SelectionSets.Add(ssName)
       ss.Clear
       Set CreateSelectionSet = ss
End Function
Public Sub BuildFilter(typeArray, dataArray, ParamArray gCodes())
       '用数组方式填充一对变量以用作为选择集过滤器使用
       Dim fType() As Integer, fData()
       Dim index As Long, i As Long
       
       index = LBound(gCodes) - 1
               
       For i = LBound(gCodes) To UBound(gCodes) Step 2
               index = index + 1
               ReDim Preserve fType(0 To index)
               ReDim Preserve fData(0 To index)
               fType(index) = CInt(gCodes(i))
               fData(index) = gCodes(i + 1)
       Next
       typeArray = fType: dataArray = fData
End Sub

王咣生 · 发表于 2004-2-16 21:20:00

好程序!

mikewolf2k · 发表于 2004-2-16 21:31:00

干什么,抢生意啊??居然用我一样的名字??

这么长?看看在说,完了再完善完善俺的.

你的getLinePoint有漏洞,对于多端点的polyline没有判断是否为一直线,好像取得是第一个和最后一个端点的坐标,应该取最外侧端点的坐标.

subtlation · 发表于 2004-2-16 21:44:00

多交流交流，才能相互提高。我是参考着４楼的那个ｖｂａ程序写的。所以就直接用了那个过程名。抱歉抱歉。

我对于多段线的顶点运算不是太熟悉，所以直接提取了起点和终点，最好应该是提取距离最远的两个顶点。

程序很长，不过下面的大部分函数都不是我写的，直接从明经中复制下来用。getLinePoint和MaxDouble在原来的基础上稍微改进了一下，以适合自己的要求。

王咣生 · 发表于 2004-2-16 21:53:00

无所谓吧!

mikewolf2k · 发表于 2004-2-16 22:07:00

建议不要新建一个polyline,不然的话所有属性都要与第一根polyline相同(图层,颜色,宽度等等),比较麻烦,还是直接改第一根polyline的端点方便.

无痕 · 发表于 2004-2-16 22:46:00

不懂vba，不过看文字，实现这样的功能，用pedit/m不行么？

subtlation · 发表于 2004-2-17 09:13:00

mikewolf2k发表于2004-2-16 22:07:00建议不要新建一个polyline,不然的话所有属性都要与第一根polyline相同(图层,颜色,宽度等等),比较麻烦,还是直接改第一根polyline的端点方便.

多段线有时可能有好几个端点，我想在合并线的同时把线变成一根线，多段线就变成只有2个端点。

subtlation · 发表于 2004-2-17 09:18:00

无痕发表于2004-2-16 22:46:00不懂vba，不过看文字，实现这样的功能，用pedit/m不行么？

对于首尾衔接的线用pedit是可以的，但对于共线不相连的线就不行了。在这个程序主要还是为了提高，其实已经有lisp的程序了。4楼的那个vba程序也可以用的。

账号		自动登录	找回密码
密码			注册

通过框选连接线的ｖｂａ程序

好程序

回复