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

zwl2929

这段程序的目的是把一个图中所有圆的编号同圆心坐标一同写入到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

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

另外，用选择集要好些

zwl2929

感谢版主，圆与编号没有什么规定，但通常编号都是靠近圆用MTEXT注明，也就是距离小于四倍的圆半径。

选择集俺还没用过呢，初学别笑话，上述程序能成功吗

雪山飞狐_lzh

用选择集试试吧，这样的代码看起来太累，而且会很慢：）

先用选择集过滤出圆

再遍历选择集，对每个圆做一个选择集（条件是到圆心距离不太远的Mtext,可以设置框选的范围）

zwl2929

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

zwl2929

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

efan2000

3. 3倍的距离比较合适，不然会将其它的文字也判断出来。
4. Sub ctoe()
5.     Dim rownum As Integer
6.     Dim Found As Boolean
7.     Dim MyObject As AcadEntity
8.    
9.     Dim MyObject1 As AcadEntity
10.     Dim Excel As Excel.Application
11.     Dim ExcelWorkbook As Object
12.     Dim ExcelSheet As Object
13.     Dim radius '圆半径
14.     Dim pt '(0 To 2) '定义数组变量，存储圆心坐标
15.     Dim pt_text '(0 To 2) '定义数组变量，存储MTEXT坐标
16.     Dim Distance As Double '计算距离
17.     Dim x As Double
18.     Dim y As Double
19.     Dim z As Double
20.    
21.     rownum = 2
22.     Found = False
23.     Set Excel = New Excel.Application '启动EXCEL
24.     Set ExcelWorkbook = Excel.Workbooks.Add
25.     Set ExcelSheet = Excel.ActiveSheet
26.     'Excel.Visible = True '显示EXCEL
27.     For Each MyObject In ThisDrawing.ModelSpace '在模型空间中遍历所有的图元
28.         If StrComp(MyObject.EntityName, "acdbcircle", 1) = 0 Then '这一句是判断对象是否是圆
29.             pt = MyObject.Center
30.             radius = MyObject.radius
31.             For Each MyObject1 In ThisDrawing.ModelSpace '在模型空间中遍历所有的图元
32.                 If StrComp(MyObject1.EntityName, "acdbMTEXT", 1) = 0 Then '这一句是判断对象是否是MTEXT
33.                     pt_text = MyObject1.InsertionPoint
34.                     x = pt(0) - pt_text(0)
35.                     y = pt(1) - pt_text(1)
36.                     z = pt(2) - pt_text(2)
37.                     Distance = Sqr((Sqr((x ^ 2) + (y ^ 2)) ^ 2) + (z ^ 2))
38.                     If Distance <= 3 * radius Then '如果距离小于四倍圆半径则该文本就是圆的编号
39.                         ExcelSheet.Cells(rownum, 1) = MyObject1.TextString '圆的编号
40.                         ExcelSheet.Cells(rownum, 2) = pt(0) '圆心坐标X值
41.                         ExcelSheet.Cells(rownum, 3) = pt(1) '圆心坐标Y值
42.                         ExcelSheet.Cells(rownum, 4) = pt(2) '圆心坐标Z值
43.                         rownum = rownum + 1
44.                         Found = True '将标记设成 True。
45.                         Exit For
46.                     End If '结束IF
47.                 End If
48.             Next MyObject1 '遍历下一个文本对象\
49.         End If
50.     Next MyObject '遍历下一个对象
51.     If Found = True Then
52.         ExcelSheet.Cells(1, 1) = "编号"
53.         ExcelSheet.Cells(1, 2) = "X"
54.         ExcelSheet.Cells(1, 3) = "Y"
55.         ExcelSheet.Cells(1, 4) = "Z"
56.         MsgBox "圆心坐标输出完毕，请检阅！"
57.     Else
58.         MsgBox "在当前模型空间中未找到圆对象！"
59.     End If
60.     Excel.Visible = True '显示EXCEL
61.     Set ExcelSheet = Nothing
62.     Set ExcelWorkbook = Nothing
63.     Set Excel = Nothing
64. End Sub

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

感谢各位给我无私的帮助，程序经过改动以后真是一目了然！我在程序里加上一段排序的内容

'对填入当前表单的内容，按第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

为了提高程序效率，我在程序中又加入了选定图层功能。

使用中我发现一个问题我百思不得其解，示例中例子在EXCEL中编号是正常的Z1、Z2......。

但在例子2中在EXCEL中编号为什么会变成

雪山飞狐_lzh

http://bbs.mjtd.com/forum.php?mod=viewthread&tid=20768

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