Private Sub cd多段线坐标查询_Click() On Error Resume Next '安全创建选择集 If Not IsNull(AcadApp.ActiveDocument.SelectionSets.Item("Test")) Then Set ssetObj = AcadApp.ActiveDocument.SelectionSets.Item("Test") ssetObj.Delete End If '创建选择集 Set ssetObj = AcadApp.ActiveDocument.SelectionSets.add("Test") '激活CAD窗口 AppActivate AcadApp.Caption AcadApp.WindowState = acMax '提示用户从屏幕选择实体对象,并加入选择集 ssetObj.SelectOnScreen '选择完毕后按回车键或单击右键 Dim pickedObjs As AcadEntity Dim retCoord As Variant For Each pickedObjs In ssetObj retCoord = pickedObjs.Coordinates AppActivate Me.Caption AcadApp.WindowState = acMin If TypeOf pickedObjs Is AcadPolyline Or TypeOf pickedObjs Is Acad3DPolyline Then '普通多义线或3维多段线 j = (UBound(pickedObjs.Coordinates) + 1) / 3 '多义线的顶点数 For i = 0 To j * 3 - 1 Step 3 If retCoord(0) = retCoord(j * 3 - 3) And retCoord(1) = retCoord(j * 3 - 2) Then '闭合时 MSFlexGrid1.Rows = j Else '非闭合时 MSFlexGrid1.Rows = j + 1 End If MSFlexGrid1.TextMatrix(i / 3 + 1, 0) = i / 3 + 1 MSFlexGrid1.TextMatrix(i / 3 + 1, 2) = Format(retCoord(i) / 1000 * Val(Text比例.Text), "0.000") MSFlexGrid1.TextMatrix(i / 3 + 1, 1) = Format(retCoord(i + 1) / 1000 * Val(Text比例.Text), "0.000") Next i ElseIf TypeOf pickedObjs Is AcadLWPolyline Then '轻便多义线 j = (UBound(pickedObjs.Coordinates) + 1) / 2 '多义线的顶点数 For i = 0 To j * 2 - 1 Step 2 If retCoord(0) = retCoord(j * 2 - 2) And retCoord(1) = retCoord(j * 2 - 1) Then '闭合时 MSFlexGrid1.Rows = j Else '非闭合时 MSFlexGrid1.Rows = j + 1 End If MSFlexGrid1.TextMatrix(i / 2 + 1, 0) = i / 2 + 1 MSFlexGrid1.TextMatrix(i / 2 + 1, 2) = Format(retCoord(i) / 1000 * Val(Text比例.Text), "0.000") MSFlexGrid1.TextMatrix(i / 2 + 1, 1) = Format(retCoord(i + 1) / 1000 * Val(Text比例.Text), "0.000") Next i Else MsgBox "您选择的不是多段线!", 64 + vbOKOnly, "地质测量" ssetObj.Delete End If Exit For Next '删除选择集 ssetObj.Delete End Sub |