zshuling 发表于 2003-10-26 08:43:00

求助：如何获得曲线上的等分点？

想通过程序自动找到样条曲线上的等分点，在绘图时可以用divide命令进行等分，但VBA里好像没有divide命令，不知道该怎么办：(请哪位高手指点一下，急，多谢了。

topirol 发表于 2003-10-26 12:37:00

用VLAX类里面的函数可以实现

zshuling 发表于 2003-10-26 13:43:00

我试试看，谢谢啦

gyl 发表于 2003-10-26 20:40:00

用SendCommand方法执行divide命令，然后生成一个选择集，包含生成的点对象或块对象，逐一提取点的定位点或块的插入点坐标即可。在VBA中大量使用VLAX曲线类函数很不稳定，经常出错，详见http://bbs.mjtd.com/forum.php?mod=viewthread&tid=11025，你若试验成功了别忘了告诉我一声。

zshuling 发表于 2003-10-30 21:43:00

试验失败：(

gyl 发表于 2003-10-30 23:43:00

在VBA中通过SendCommand方法执行divide命令的方法是可行的。

zshuling 发表于 2003-10-31 09:11:00

老是出错，你是怎么做的，能给我是、借鉴一下么？

gyl 发表于 2003-10-31 20:57:00

这是我的程序，只不过使用了MEASURE命令而不是DIVIDE命令，但道理是相同的

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 发表于 2003-11-3 21:12:00

楼主，问题解决没有？

zshuling 发表于 2003-11-4 08:14:00

呵呵，谢谢你，等分的问题已经解决了，但是程序其它部分还有点小问题，有时候好用有时候不好用，目前还没找到原因所在。不过会继续努力^_^
页: [1] 2
查看完整版本: 求助：如何获得曲线上的等分点？