[求助][讨论]这段连接线的代码为什么会出现如下的错误窗口
<p><font face="Verdana">这段连接线的代码为什么会出现如下的错误窗口，框选连接时才会出现，点选不会。</font></p><p><font face="Verdana">Sub uniteSS()<br/> 'On Error Resume Next<br/> Dim ssetObj As AcadSelectionSet<br/> Set ssetObj = CreateSelectionSet("uniteSS")<br/> Dim fType, fData<br/> BuildFilter fType, fData, -4, "<or", 0, "line", 0, "LWPolyline", -4, "or>"<br/> '屏选直线或多段线<br/> ssetObj.SelectOnScreen fType, fData<br/> Dim i As Integer<br/> If ssetObj.Count <= 1 Then<br/> ThisDrawing.Utility.Prompt "选择的线少于两个，退出命令。"<br/> Exit Sub<br/> End If<br/> <br/> Dim line1 As Object<br/> Dim line2 As Object<br/> <br/> Set line1 = ssetObj(0)<br/> Dim pd As Boolean<br/> For i = 1 To ssetObj.Count<br/> Set line2 = ssetObj(i)<br/> '连接线<br/> pd = unite2Line(line1, line2)<br/> '如果连接不成功，则退出命令。<br/> If Not pd Then ssetObj.Delete: Exit Sub<br/> Next<br/> ssetObj.Delete<br/>End Sub</font></p>
<p><font face="Verdana"></font> </p>
<p><font face="Verdana">Sub uniteline()<br/> On Error Resume Next<br/> '取得线<br/> Dim line1 As Object<br/> Dim line2 As Object<br/> Dim pt1, pt2, pt3, pt4, basePnt As AcadEntity<br/> Dim lpt1, lpt2 As Variant<br/> <br/> gwGetEntity line1, basePnt, "请选择第一根直线或多段线：", "AcDbLine", "AcDbPolyline"<br/> If line1 Is Nothing Then<br/> ThisDrawing.Utility.Prompt "用户取消，退出命令。"<br/> Exit Sub<br/> End If<br/> <br/> gwGetEntity line2, basePnt, "请选择第二根直线或多段线：", "AcDbLine", "AcDbPolyline"<br/> If line2 Is Nothing Then<br/> ThisDrawing.Utility.Prompt "用户取消，退出命令。"<br/> Exit Sub<br/> End If<br/> '连接线<br/> unite2Line line1, line2<br/>End Sub</font></p><font face="Verdana">
<p><br/>Function unite2Line(ByRef line1 As Object, ByVal line2 As Object) As Boolean<br/> '连接线函数，连接后的线返回到变量line1中，如果连接成功，unite2Line返回true，否则为false<br/> On Error Resume Next<br/> unite2Line = False<br/> <br/> If line1.Handle = line2.Handle Then<br/> ThisDrawing.Utility.Prompt "选择的是同一直线或多段线，退出命令。"<br/> Exit Function<br/> End If<br/> <br/> getLinePoint line1, pt1, pt2<br/> getLinePoint line2, pt3, pt4<br/> <br/> Dim A1, A2, A3 As Double<br/> Dim maxdi As Double<br/> A1 = ThisDrawing.Utility.AngleFromXAxis(pt1, pt2)<br/> A2 = ThisDrawing.Utility.AngleFromXAxis(pt3, pt4)<br/> A3 = ThisDrawing.Utility.AngleFromXAxis(pt1, pt3)<br/> '判断四点是否共线<br/> If Abs(A1 - A2) < 0.0000001 And (Abs(A1 - A3) < 0.0000001 Or Abs(Abs(A1 - A3) - PI) < 0.0000001) Then<br/> '取得距离最远的两个点。<br/> maxdi = MaxDouble(GetDistance(pt1, pt2), GetDistance(pt1, pt3), GetDistance(pt1, pt4), _<br/> GetDistance(pt2, pt3), GetDistance(pt2, pt4), GetDistance(pt3, pt4))<br/> If GetDistance(pt1, pt2) = maxdi Then lpt1 = pt1: lpt2 = pt2<br/> If GetDistance(pt1, pt3) = maxdi Then lpt1 = pt1: lpt2 = pt3<br/> If GetDistance(pt1, pt4) = maxdi Then lpt1 = pt1: lpt2 = pt4<br/> If GetDistance(pt2, pt3) = maxdi Then lpt1 = pt2: lpt2 = pt3<br/> If GetDistance(pt2, pt4) = maxdi Then lpt1 = pt2: lpt2 = pt4<br/> If GetDistance(pt3, pt4) = maxdi Then lpt1 = pt3: lpt2 = pt4<br/> '画直线<br/> Select Case line1.ObjectName<br/> Case "AcDbLine"<br/> line1.StartPoint = lpt1<br/> line1.EndPoint = lpt2<br/> line2.Delete<br/> ThisDrawing.Utility.Prompt "线段已连接为直线．"<br/> unite2Line = True<br/> Case "AcDbPolyline"<br/> Dim newPline As AcadLWPolyline<br/> Set newPline = AddLWPlineSeg(lpt1, lpt2, line1.ConstantWidth)<br/> newPline.Layer = line1.Layer<br/> newPline.color = line1.color<br/> newPline.Linetype = line1.Linetype<br/> line1.Delete<br/> line2.Delete<br/> Set line1 = newPline<br/> ThisDrawing.Utility.Prompt "线段已连接为多段线．"<br/> unite2Line = True<br/> End Select<br/> Else: ThisDrawing.Utility.Prompt "两线不在同一直线上，退出命令．"<br/> End If<br/>End Function<br/> <br/> <br/> <br/>'以下是上述代码调用的函数</p>
<p><br/>'创建轻量多段线（只有两个顶点的直线多段线）<br/>Public Function AddLWPlineSeg(ByVal ptSt As Variant, ByVal ptEn As Variant, Optional ByVal width As Double = 0) As AcadLWPolyline<br/> Dim objPline As AcadLWPolyline<br/> Dim ptArr(0 To 3) As Double<br/> <br/> ptArr(0) = ptSt(0)<br/> ptArr(1) = ptSt(1)<br/> ptArr(2) = ptEn(0)<br/> ptArr(3) = ptEn(1)<br/> <br/> Set objPline = ThisDrawing.ModelSpace.AddLightWeightPolyline(ptArr)<br/> objPline.ConstantWidth = width<br/> objPline.Update<br/> Set AddLWPlineSeg = objPline<br/>End Function<br/>Public Function getLinePoint(ent As AcadEntity, ByRef Point1 As Variant, ByRef Point2 As Variant)<br/> '本函数得到线的端点，其中point1为Ｙ坐标较小的点<br/> Dim p1(2) As Double<br/> Dim p2(2) As Double<br/> Dim k As Integer<br/> On Error Resume Next<br/> Select Case ent.ObjectName<br/> Case "AcDbLine"<br/> Point1 = ent.StartPoint<br/> Point2 = ent.EndPoint<br/> If ThisDrawing.Utility.AngleFromXAxis(Point1, Point2) >= PI Then<br/> Point1 = ent.EndPoint<br/> Point2 = ent.StartPoint<br/> End If<br/> Case "AcDbPolyline"<br/> Dim entCo As Variant<br/> entCo = ent.Coordinates<br/> k = UBound(entCo)<br/> If k >= 3 Then<br/> p1(0) = entCo(0): p1(1) = entCo(1)<br/> p2(0) = entCo(k - 1): p2(1) = entCo(k)<br/> If ThisDrawing.Utility.AngleFromXAxis(p1, p2) >= PI Then<br/> p2(0) = entCo(0): p2(1) = entCo(1)<br/> p1(0) = entCo(k - 1): p1(1) = entCo(k)<br/> End If<br/> Point1 = p1: Point2 = p2<br/> End If<br/> End Select<br/>End Function<br/>Public Function PI() As Double<br/> PI = Atn(1) * 4<br/>End Function<br/>Public Sub GetEntityEx(ent As Object, pickedPoint, Optional Prompt)<br/> '选择实体，直到用户取消操作<br/> On Error Resume Next<br/>StartLoop:<br/> ThisDrawing.Utility.GetEntity ent, pt, Prompt<br/> If Err Then<br/> If ThisDrawing.GetVariable("errno") = 7 Then<br/> Err.Clear<br/> GoTo StartLoop<br/> Else<br/> Err.Raise vbObjectError + 5, , "用户取消操作"<br/> End If<br/> End If<br/>End Sub<br/>Public Sub gwGetEntity(ent As Object, pickedPoint, Prompt As String, ParamArray gType())<br/> '选择某一类型的实体，如果选择错误则继续，按ESC退出<br/> 'gtype是实体名称，不区分大小写，可以用通配符号，如"AcDbBlockReference"，"acdb*text"等<br/> Dim i As Integer<br/> Dim pd As Boolean<br/> pd = False<br/> Do<br/> GetEntityEx ent, pickedPoint, Prompt<br/> <br/> If ent Is Nothing Then<br/> Exit Do<br/> ElseIf UBound(gType) - LBound(gType) + 1 = 0 Then<br/> Exit Do<br/> Else<br/> For i = LBound(gType) To UBound(gType)<br/> If UCase(ent.ObjectName) Like UCase(gType(i)) Then<br/> Exit Do<br/> Else<br/> pd = True<br/> End If<br/> Next i<br/> If pd Then ThisDrawing.Utility.Prompt "选择的实体不符合要求．"<br/> End If<br/> Loop<br/> <br/>End Sub<br/>'计算两点之间距离<br/>Public Function GetDistance(sp As Variant, ep As Variant) As Double<br/> Dim x As Double<br/> Dim y As Double<br/> Dim z As Double<br/> <br/> x = sp(0) - ep(0)<br/> y = sp(1) - ep(1)<br/> z = sp(2) - ep(2)<br/> <br/> GetDistance = Sqr((x ^ 2) + (y ^ 2) + (z ^ 2))<br/>End Function<br/>'返回两个Double类型变量的最大值<br/>Public Function MaxDouble(ByVal a As Double, ParamArray b()) As Double<br/> MaxDouble = a<br/> Dim i As Integer<br/> For i = LBound(b) To UBound(b)<br/> If b(i) > MaxDouble Then MaxDouble = b(i)<br/> Next i<br/>End Function<br/>Public Function CreateSelectionSet(Optional ssName As String = "ss") As AcadSelectionSet<br/> '返回一个空白选择集<br/> <br/> Dim ss As AcadSelectionSet<br/> <br/> On Error Resume Next<br/> Set ss = ThisDrawing.SelectionSets(ssName)<br/> If Err Then Set ss = ThisDrawing.SelectionSets.Add(ssName)<br/> ss.Clear<br/> Set CreateSelectionSet = ss<br/>End Function<br/>Public Sub BuildFilter(typeArray, dataArray, ParamArray gCodes())<br/> '用数组方式填充一对变量以用作为选择集过滤器使用<br/> Dim fType() As Integer, fData()<br/> Dim index As Long, i As Long<br/> <br/> index = LBound(gCodes) - 1<br/> <br/> For i = LBound(gCodes) To UBound(gCodes) Step 2<br/> index = index + 1<br/> ReDim Preserve fType(0 To index)<br/> ReDim Preserve fData(0 To index)<br/> fType(index) = CInt(gCodes(i))<br/> fData(index) = gCodes(i + 1)<br/> Next<br/> typeArray = fType: dataArray = fData<br/>End Sub</p>
<p></font> </p> 希望有高手解答，这是合并（连接）一条直线上的两条线的程序。//subtlationuniteSS为框选。uniteline为一根一根选择（只能选择两根）。对多段线和直线都有效。 <p>希望大虾们多多帮助，框选一直有错误：<font face="Verdana">线段已连接为直线．执行错误</font> CAD2004版本的</p> <p>楼主犯了一个很常见的错误：在每次程序运行前应判断目标选择集(即本程序代码中的uniteSS)是否已存在，若是的话应先删除该选择集。否则可能导致程序出现意外。</p>
<p> </p>
<p>以下为修改后的部分代码，供参考：</p>
<p> </p>
<p><font face="Verdana">Sub uniteSS()</font></p>
<p><font face="Verdana"> On Error Resume Next<br/> Dim ss As AcadSelectionSets<br/> Dim ssetObj As AcadSelectionSet<br/> <br/> If Not IsNull(ss.Item("uniteSS")) Then<br/> Set ssetObj = CreateSelectionSet("uniteSS")<br/> ssetObj.Delete<br/> End If<br/> <br/> Set ssetObj = CreateSelectionSet("uniteSS")<br/> Dim fType, fData<br/> BuildFilter fType, fData, -4, "<or", 0, "line", 0, "LWPolyline", -4, "or>"</font></p>
<p> ………………</p>
<p> </p> <p>谢谢2楼，已经解决</p>
页:
[1]