[原创]刚完成的VB-返回多段线顶点坐标的代码
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
DUOXIEA 收藏多段线顶点坐标 收下了。。留给以后用 谢谢分享！
页:
[1]