[求助][讨论]这段连接线的代码为什么会出现如下的错误窗口
这段连接线的代码为什么会出现如下的错误窗口，框选连接时才会出现，点选不会。Sub uniteSS()
'On Error Resume Next
Dim ssetObj As AcadSelectionSet
Set ssetObj = CreateSelectionSet("uniteSS")
Dim fType, fData
BuildFilter fType, fData, -4, ""
'屏选直线或多段线
ssetObj.SelectOnScreen fType, fData
Dim i As Integer
If ssetObj.Count
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)
'创建轻量多段线（只有两个顶点的直线多段线）
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
希望有高手解答，这是合并（连接）一条直线上的两条线的程序。复制代码复制代码 希望大虾们多多帮助，框选一直有错误：线段已连接为直线．执行错误CAD2004版本的
楼主犯了一个很常见的错误：在每次程序运行前应判断目标选择集(即本程序代码中的uniteSS)是否已存在，若是的话应先删除该选择集。否则可能导致程序出现意外。
以下为修改后的部分代码，供参考：
Sub uniteSS()
On Error Resume Next
Dim ss As AcadSelectionSets
Dim ssetObj As AcadSelectionSet
If Not IsNull(ss.Item("uniteSS")) Then
Set ssetObj = CreateSelectionSet("uniteSS")
ssetObj.Delete
End If
Set ssetObj = CreateSelectionSet("uniteSS")
Dim fType, fData
BuildFilter fType, fData, -4, ""
………………
谢谢2楼，已经解决
页:
[1]