[VBA程序]：将曲线离散化的源程序

gyl

自己写的程序。功能是从当前DWG文件中所有的多段线按一定间隔取点，并将点的坐标保存到文件。点是调用measure命令生成的。

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