[测试]：通过程序自动找到样条曲线上的等分点

zzz8662

程序目的：想通过程序自动找到样条曲线上的等分点
但是，运行结果不正确，请各位大虾赐教，谢谢！
Sub GetPointOfPline()
    Const ds As Double = 5          '曲线上的取点间隔
    Dim SsetObj As AcadSelectionSet  '选择集对象
    Dim SsetPoint As AcadSelectionSet  '点选择集
    Dim SsetName As String           '选择集名称
    Dim PointObj As AcadPoint        '点对象
    Dim CommandSTR As String
    Dim Pt() As Double                  '点坐标
    Dim i As Integer, j As Integer
    Dim Num1 As Integer, Num2 As Integer

    Dim gpCode(0) As Integer
    Dim datavalue(0) As Variant
    Dim groupCode As Variant, dataCode As Variant
   
    '选择集名称
    SsetName = "SplineSet"
    '建立选择集
    On Error Resume Next
    Set SsetObj = ThisDrawing.SelectionSets.Add(SsetName)
    If Err Then
        Set SsetObj = ThisDrawing.SelectionSets.Item(SsetName)
        SsetObj.Clear
        Err.Clear
    End If
    On Error GoTo 0
   
    '将曲线添加到选择集
    gpCode(0) = 0
    datavalue(0) = "polyline"
    groupCode = gpCode
    dataCode = datavalue
    SsetObj.Select acSelectionSetAll, , , groupCode, dataCode
   
    '打开文件用于存储曲线离散化后的点的坐标
    Open "D:\curve.txt" For Output As #1
    Num1 = SsetObj.Count
    Print #1, "曲线数目：" & Num1
   
    '选择集名称
    SsetName = "PointSet"
    '建立选择集
    On Error Resume Next
    Set SsetPoint = ThisDrawing.SelectionSets.Add(SsetName)
    If Err Then
        Set SsetPoint = ThisDrawing.SelectionSets.Item(SsetName)
        SsetPoint.Clear
        Err.Clear
    End If
    On Error GoTo 0
    '将全部点添加到选择集
    gpCode(0) = 0
    datavalue(0) = "point"
    groupCode = gpCode
    dataCode = datavalue
   
    '在曲线上每隔一定距离取一个点，依次将点的坐标写入文件
    For i = 1 To Num1
        CommandSTR = "(Handent """ & SsetObj.Item(i - 1).Handle & """)"
        ThisDrawing.SendCommand "MEASURE" & vbCr & CommandSTR & vbCr & CStr(ds) & vbCr
        SsetPoint.Select acSelectionSetAll, , , groupCode, dataCode
        Num2 = SsetPoint.Count
        If Num2 <> 0 Then
            ReDim Pt(Num2 - 1, 2) As Double
            For j = 0 To Num2 - 1
                Set PointObj = SsetPoint.Item(j)
                Pt(j, 0) = PointObj.Coordinates(0)
                Pt(j, 1) = PointObj.Coordinates(1)
                Pt(j, 2) = PointObj.Coordinates(2)
            Next j
            SsetPoint.Erase '删除选择集中所有图元
            Print #1, "第" & i & "条曲线"
            For j = 0 To Num2 - 1
                Print #1, Format(Pt(j, 0), "0.000"); " "; Format(Pt(j, 1), "0.000"); " "; Format(Pt(j, 2), "0.000")
            Next j
        End If
    Next i
    Close 1
    SsetObj.Delete
   
End Sub

gyl

这是我去年写的一段程序，发表在这里http://www.xdcad.net/forum/showthread.php?threadid=108529
你把datavalue(0) = "polyline"一行中的polyline换为spline就可以求样条曲线等分点了。只是由于调用CAD的命令，在曲线数量多时运行速度比较慢；当时本想利用VLAX和曲线类函数，但由于不稳定经常出错而作罢。

zzz8662

谢谢了！在明经你不回复啊，我只好来这里了。呵呵