乐筑天下

搜索
欢迎各位开发者和用户入驻本平台 尊重版权,从我做起,拒绝盗版,拒绝倒卖 签到、发布资源、邀请好友注册,可以获得银币 请注意保管好自己的密码,避免账户资金被盗
查看: 177|回复: 9

求助:如何获得曲线上的等分点?

[复制链接]

6

主题

19

帖子

2

银币

初来乍到

Rank: 1

铜币
43
发表于 2003-10-26 08:43:00 | 显示全部楼层 |阅读模式
想通过程序自动找到样条曲线上的等分点,在绘图时可以用divide命令进行等分,但VBA里好像没有divide命令,不知道该怎么办:(请哪位高手指点一下,急,多谢了。
回复

使用道具 举报

28

主题

117

帖子

4

银币

后起之秀

Rank: 20Rank: 20Rank: 20Rank: 20

铜币
229
发表于 2003-10-26 12:37:00 | 显示全部楼层
用VLAX类里面的函数可以实现
回复

使用道具 举报

6

主题

19

帖子

2

银币

初来乍到

Rank: 1

铜币
43
发表于 2003-10-26 13:43:00 | 显示全部楼层
我试试看,谢谢啦
回复

使用道具 举报

gyl

15

主题

127

帖子

7

银币

初露锋芒

Rank: 3Rank: 3Rank: 3

铜币
187
发表于 2003-10-26 20:40:00 | 显示全部楼层
用SendCommand方法执行divide命令,然后生成一个选择集,包含生成的点对象或块对象,逐一提取点的定位点或块的插入点坐标即可。在VBA中大量使用VLAX曲线类函数很不稳定,经常出错,详见http://bbs.mjtd.com/forum.php?mod=viewthread&tid=11025,你若试验成功了别忘了告诉我一声。
回复

使用道具 举报

6

主题

19

帖子

2

银币

初来乍到

Rank: 1

铜币
43
发表于 2003-10-30 21:43:00 | 显示全部楼层
试验失败:(
回复

使用道具 举报

gyl

15

主题

127

帖子

7

银币

初露锋芒

Rank: 3Rank: 3Rank: 3

铜币
187
发表于 2003-10-30 23:43:00 | 显示全部楼层
在VBA中通过SendCommand方法执行divide命令的方法是可行的。
回复

使用道具 举报

6

主题

19

帖子

2

银币

初来乍到

Rank: 1

铜币
43
发表于 2003-10-31 09:11:00 | 显示全部楼层
老是出错,你是怎么做的,能给我是、借鉴一下么?
回复

使用道具 举报

gyl

15

主题

127

帖子

7

银币

初露锋芒

Rank: 3Rank: 3Rank: 3

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

使用道具 举报

gyl

15

主题

127

帖子

7

银币

初露锋芒

Rank: 3Rank: 3Rank: 3

铜币
187
发表于 2003-11-3 21:12:00 | 显示全部楼层
楼主,问题解决没有?
回复

使用道具 举报

6

主题

19

帖子

2

银币

初来乍到

Rank: 1

铜币
43
发表于 2003-11-4 08:14:00 | 显示全部楼层
呵呵,谢谢你,等分的问题已经解决了,但是程序其它部分还有点小问题,有时候好用有时候不好用,目前还没找到原因所在。不过会继续努力^_^
回复

使用道具 举报

发表回复

您需要登录后才可以回帖 登录 | 立即注册

本版积分规则

  • 微信公众平台

  • 扫描访问手机版

  • 点击图片下载手机App

QQ|关于我们|小黑屋|乐筑天下 繁体中文

GMT+8, 2025-6-29 14:21 , Processed in 1.294019 second(s), 72 queries .

© 2020-2025 乐筑天下

联系客服 关注微信 帮助中心 下载APP 返回顶部 返回列表