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

zshuling

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

topirol

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

zshuling

我试试看，谢谢啦

gyl

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

zshuling

试验失败：(

gyl

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

zshuling

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

gyl

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

2. 
   
3. Sub GetPointOfPline()
   
4.     Const ds As Double = 5          '曲线上的取点间隔
   
5.     Dim SsetObj As AcadSelectionSet  '选择集对象
   
6.     Dim SsetPoint As AcadSelectionSet  '点选择集
   
7.     Dim SsetName As String           '选择集名称
   
8.     Dim PointObj As AcadPoint        '点对象
   
9.     Dim CommandSTR As String
   
10.     Dim Pt() As Double                  '点坐标
    
11.     Dim i As Integer, j As Integer
    
12.     Dim Num1 As Integer, Num2 As Integer
    
13. 
    
14.     Dim gpCode(0) As Integer
    
15.     Dim dataValue(0) As Variant
    
16.     Dim groupCode As Variant, dataCode As Variant
    
17.    
    
18.     '选择集名称
    
19.     SsetName = "SplineSet"
    
20.     '建立选择集
    
21.     On Error Resume Next
    
22.     Set SsetObj = ThisDrawing.SelectionSets.Add(SsetName)
    
23.     If Err Then
    
24.         Set SsetObj = ThisDrawing.SelectionSets.Item(SsetName)
    
25.         SsetObj.Clear
    
26.         Err.Clear
    
27.     End If
    
28.     On Error GoTo 0
    
29.    
    
30.     '将曲线添加到选择集
    
31.     gpCode(0) = 0
    
32.     dataValue(0) = "polyline"
    
33.     groupCode = gpCode
    
34.     dataCode = dataValue
    
35.     SsetObj.Select acSelectionSetAll, , , groupCode, dataCode
    
36.    
    
37.     '打开文件用于存储曲线离散化后的点的坐标
    
38.     Open "D:\curve.txt" For Output As #1
    
39.     Num1 = SsetObj.Count
    
40.     Print #1, "曲线数目：" & Num1
    
41.    
    
42.     '选择集名称
    
43.     SsetName = "PointSet"
    
44.     '建立选择集
    
45.     On Error Resume Next
    
46.     Set SsetPoint = ThisDrawing.SelectionSets.Add(SsetName)
    
47.     If Err Then
    
48.         Set SsetPoint = ThisDrawing.SelectionSets.Item(SsetName)
    
49.         SsetPoint.Clear
    
50.         Err.Clear
    
51.     End If
    
52.     On Error GoTo 0
    
53.     '将全部点添加到选择集
    
54.     gpCode(0) = 0
    
55.     dataValue(0) = "point"
    
56.     groupCode = gpCode
    
57.     dataCode = dataValue
    
58.    
    
59.     '在曲线上每隔一定距离取一个点，依次将点的坐标写入文件
    
60.     For i = 1 To Num1
    
61.         CommandSTR = "(Handent """ & SsetObj.Item(i - 1).Handle & """)"
    
62.         ThisDrawing.SendCommand "MEASURE" & vbCr & CommandSTR & vbCr & CStr(ds) & vbCr
    
63.         SsetPoint.Select acSelectionSetAll, , , groupCode, dataCode
    
64.         Num2 = SsetPoint.Count
    
65.         If Num2 <> 0 Then
    
66.             ReDim Pt(Num2 - 1, 2) As Double
    
67.             For j = 0 To Num2 - 1
    
68.                 Set PointObj = SsetPoint.Item(j)
    
69.                 Pt(j, 0) = PointObj.Coordinates(0)
    
70.                 Pt(j, 1) = PointObj.Coordinates(1)
    
71.                 Pt(j, 2) = PointObj.Coordinates(2)
    
72.             Next j
    
73.             SsetPoint.Erase '删除选择集中所有图元
    
74.             Print #1, "第" & i & "条曲线"
    
75.             For j = 0 To Num2 - 1
    
76.                 Print #1, Format(Pt(j, 0), "0.000"); " "; Format(Pt(j, 1), "0.000"); " "; Format(Pt(j, 2), "0.000")
    
77.             Next j
    
78.         End If
    
79.     Next i
    
80.     Close 1
    
81.     SsetObj.Delete
    
82.    
    
83. End Sub
    

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

gyl

楼主，问题解决没有？

zshuling

呵呵，谢谢你，等分的问题已经解决了，但是程序其它部分还有点小问题，有时候好用有时候不好用，目前还没找到原因所在。不过会继续努力^_^