|
这段连接线的代码为什么会出现如下的错误窗口，框选连接时才会出现，点选不会。
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
'以下是上述代码调用的函数
'创建轻量多段线（只有两个顶点的直线多段线）
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
|
发表于 2010-8-11 21:52:00
置顶卡
变色卡
显身卡
楼主
