大家帮我看看这段程序在哪出问题的

zwl2929 · 发表于 2006-10-4 15:18:00

这段程序的目的是把一个图中所有圆的编号同圆心坐标一同写入到EXCLE中（其中圆编号就是在圆边上用MTEXT注明的一个编号。
Sub ctoe()
Dim rownum As Integer
Dim Found As Boolean
Dim MyObject As AcadEntity
Dim MyObject1 As AcadEntity
rownum = 2
Found = False
For Each MyObject In ThisDrawing.ModelSpace '在模型空间中遍历所有的图元
If StrComp(MyObject.EntityName, "acdbcircle", 1) = 0 Then '这一句是判断对象是否是圆
If rownum = 2 Then '若是圆对象
Dim Excel As Excel.Application
Dim ExcelWorkbook As Object
Dim ExcelSheet As Object
Set Excel = New Excel.Application '启动EXCEL
Set ExcelWorkbook = Excel.Workbooks.Add
Set ExcelSheet = Excel.ActiveSheet
'Excel.Visible = True '显示EXCEL
Dim pt '(0 To 2) '定义数组变量，存储圆心坐标
Dim radius '圆半径
For Each MyObject1 In ThisDrawing.ModelSpace /在模型空间中遍历所有的图元
  If StrComp(MyObject1.EntityName, "acdbMTEXT", 1) = 0 Then '这一句是判断对象是否是MTEXT
   If rownum = 2 Then '若是MTEXT对象
   Dim pt_text '(0 To 2) '定义数组变量，存储MTEXT坐标
   pt = MyObject.Center
   pt_text = MyObject1.InsertionPoint

   Dim Distance As Double '计算距离
   Dim x As Double
   Dim y As Double
   Dim z As Double
   x = pt(0) - pt_text(0)
   y = pt(1) - pt_text(1)
   z = pt(2) - pt_text(2)
   Distance = Sqr((Sqr((x ^ 2) + (y ^ 2)) ^ 2) + (z ^ 2))

   radius = MyObject.radius
      If Distance
pt = MyObject.Center
ExcelSheet.Cells(rownum, 1) = MyObject1.TextString '圆的编号
(rownum, 2) = pt(0) '圆心坐标X值
ExcelSheet.Cells(rownum, 3) = pt(1) '圆心坐标Y值
ExcelSheet.Cells(rownum, 4) = pt(2) '圆心坐标Z值
rownum = rownum + 1
Found = True '将标记设成 True。
End If '结束IF
Next MyObject1 '遍历下一个文本对象
Next MyObject '遍历下一个对象
If Found = True Then
ExcelSheet.Cells(1, 1) = "编号"
ExcelSheet.Cells(1, 2) = "X"
ExcelSheet.Cells(1, 3) = "Y"
ExcelSheet.Cells(1, 4) = "Z"
MsgBox "圆心坐标输出完毕，请检阅！"
Excel.Visible = True '显示EXCEL
Set ExcelSheet = Nothing
Set ExcelWorkbook = Nothing
Set Excel = Nothing
Else
MsgBox "在当前模型空间中未找到圆对象！"
End If
End Sub
本程序根据前人程序修改而成，大家看看这程序的问题出在哪，思路有无问题，万望高人多指点，俺是初学VBA！

本帖以下内容被隐藏保护；需要你回复后，才能看到！

游客，如果您要查看本帖隐藏内容请回复

雪山飞狐_lzh · 发表于 2006-10-4 15:26:00

编号和圆的距离有规定么，只是在旁边的话不好办，现在网吧没办法下载，直接贴图看看
另外，用选择集要好些

zwl2929 · 发表于 2006-10-4 15:41:00

感谢版主，圆与编号没有什么规定，但通常编号都是靠近圆用MTEXT注明，也就是距离小于四倍的圆半径。
选择集俺还没用过呢，初学别笑话，上述程序能成功吗

雪山飞狐_lzh · 发表于 2006-10-4 15:50:00

用选择集试试吧，这样的代码看起来太累，而且会很慢：）
先用选择集过滤出圆
再遍历选择集，对每个圆做一个选择集（条件是到圆心距离不太远的Mtext,可以设置框选的范围）

zwl2929 · 发表于 2006-10-4 16:13:00

版主:上述程序能成的话，最好能帮我修改一下，先不考虑效率问题，用选择集的话我可能还要学较长时间，

zwl2929 · 发表于 2006-10-4 16:14:00

该程序读坐标是没有问题，只是编号问题一直搞不定，加了读编号的语句以后就不能运行了，百思不得其解！

efan2000 · 发表于 2006-10-6 18:53:00

[code]3倍的距离比较合适，不然会将其它的文字也判断出来。
Sub ctoe()
Dim rownum As Integer
Dim Found As Boolean
Dim MyObject As AcadEntity

Dim MyObject1 As AcadEntity
Dim Excel As Excel.Application
Dim ExcelWorkbook As Object
Dim ExcelSheet As Object
Dim radius '圆半径
Dim pt '(0 To 2) '定义数组变量，存储圆心坐标
Dim pt_text '(0 To 2) '定义数组变量，存储MTEXT坐标
Dim Distance As Double '计算距离
Dim x As Double
Dim y As Double
Dim z As Double

rownum = 2
Found = False
Set Excel = New Excel.Application '启动EXCEL
Set ExcelWorkbook = Excel.Workbooks.Add
Set ExcelSheet = Excel.ActiveSheet
'Excel.Visible = True '显示EXCEL
For Each MyObject In ThisDrawing.ModelSpace '在模型空间中遍历所有的图元
      If StrComp(MyObject.EntityName, "acdbcircle", 1) = 0 Then '这一句是判断对象是否是圆
         pt = MyObject.Center
         radius = MyObject.radius
         For Each MyObject1 In ThisDrawing.ModelSpace '在模型空间中遍历所有的图元
            If StrComp(MyObject1.EntityName, "acdbMTEXT", 1) = 0 Then '这一句是判断对象是否是MTEXT
                  pt_text = MyObject1.InsertionPoint
                  x = pt(0) - pt_text(0)
                  y = pt(1) - pt_text(1)
                  z = pt(2) - pt_text(2)
                  Distance = Sqr((Sqr((x ^ 2) + (y ^ 2)) ^ 2) + (z ^ 2))
                  If Distance 感谢各位给我无私的帮助，程序经过改动以后真是一目了然！我在程序里加上一段排序的内容
'对填入当前表单的内容，按第1列进行排序,
'范围是从A1单元格开始的整个工作表
Excel.Worksheets("Sheet1").Range("A1").Sort _
      key1:=Excel.Worksheets("Sheet1").Columns("A"), _
      Header:=xlGuess
以后排出来的结果是z1、Z10、Z11、Z12、Z13、Z14、Z15、Z16、Z17、Z18、Z19、Z2、Z20、Z21............(EXCEL排序出来也一样），能否修改程序使排出来的效果是z1、Z2、Z3、Z4、Z5、Z6、Z7、Z8、Z9、Z10、Z11、Z12、Z13、Z14、Z15、Z16、Z17、Z18、Z19、Z20、Z21..........,我知道在EXCEL中可以增加一列输入公式--RIGHT(A1,LEN(A1)-1)，然后再对该列进行排序就可，在CAD里面如何用代码来实现我就不知如何下手了，高手请多指点

zwl2929 · 发表于 2006-10-6 21:46:00

请点击此处下载

请先注册会员后在进行下载

已注册会员，请先登录后下载

文件名称:ho0kqcdhkhp.rar
下载次数:0 文件大小:35.51 KB 售价:2银币 [记录]
下载权限: 不限以上或 Vip会员 [开通Vip] [签到领银币] [免费赚银币]

为了提高程序效率，我在程序中又加入了选定图层功能。
使用中我发现一个问题我百思不得其解，示例中例子在EXCEL中编号是正常的Z1、Z2......。
但在例子2中在EXCEL中编号为什么会变成{\fArial|b0|i0|c0|p32;z1}、 {\fArial|b0|i0|c0|p32;z2}又要如何才能解决例子2中的编号问题？

zwl2929 · 发表于 2006-10-7 09:41:00

你可以在获取编号后，直接把Z1的格式改成Z01的格式

大家帮我看看这段程序在哪出问题的

发表回复

精选推荐