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

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 <= 4 * radius Then '如果距离小于四倍圆半径则该文本就是圆的编号         
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

本帖最后由作者于 2006-10-4 19:25:48 编辑 该程序读坐标是没有问题，只是编号问题一直搞不定，加了读编号的语句以后就不能运行了，百思不得其解！

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

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 <= 3 * radius Then '如果距离小于四倍圆半径则该文本就是圆的编号
 ExcelSheet.Cells(rownum, 1) = MyObject1.TextString '圆的编号
 ExcelSheet.Cells(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。
 Exit For
 End If '结束IF
 End If
 Next MyObject1 '遍历下一个文本对象\
 End If
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 "圆心坐标输出完毕，请检阅！"
Else
 MsgBox "在当前模型空间中未找到圆对象！"
End If
Excel.Visible = True '显示EXCEL
Set ExcelSheet = Nothing
Set ExcelWorkbook = Nothing
Set Excel = Nothing
End Sub

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

本帖最后由作者于 2006-10-6 23:24:03 编辑 感谢各位给我无私的帮助，程序经过改动以后真是一目了然！我在程序里加上一段排序的内容
'对填入当前表单的内容，按第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-7 09:41:00

为了提高程序效率，我在程序中又加入了选定图层功能。
使用中我发现一个问题我百思不得其解，示例中例子在EXCEL中编号是正常的Z1、Z2......。
但在例子2中在EXCEL中编号为什么会变成<COLGROUP><COL style="WIDTH: 166pt; mso-width-source: userset; mso-width-alt: 7072" width="221">{\fArial|b0|i0|c0|p32;z1}、 <COLGROUP><COL style="WIDTH: 166pt; mso-width-source: userset; mso-width-alt: 7072" width="221">{\fArial|b0|i0|c0|p32;z2}又要如何才能解决例子2中的编号问题？

雪山飞狐_lzh 发表于 2006-10-7 11:16:00

<A href="http://bbs.mjtd.com/forum.php?mod=viewthread&tid=20768" target="_blank" >http://bbs.mjtd.com/forum.php?mod=viewthread&tid=20768</A>
你可以在获取编号后，直接把Z1的格式改成Z01的格式

页: [1]

明经CAD社区's Archiver

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