[原创]刚完成的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

sunny2008

DUOXIEA

crazylsp

收藏多段线顶点坐标

随风缘

收下了。。留给以后用

wenlisa

谢谢分享！