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

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 SubSub 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 SubFunction 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

王咣生 发表于 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:00static/image/common/back.gif建议不要新建一个polyline,不然的话所有属性都要与第一根polyline相同(图层,颜色,宽度等等),比较麻烦,还是直接改第一根polyline的端点方便.

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

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

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

对于首尾衔接的线用pedit是可以的，但对于共线不相连的线就不行了。

在这个程序主要还是为了提高，其实已经有lisp的程序了。4楼的那个vba程序也可以用的。<BR>

页: [1] 2

明经CAD社区's Archiver

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

好程序

回复