[VBA程序]：如何编写把一个CAD图中所有圆心坐标在EXCLE中列出来的VBA代码

zwl2929

工作中经常需要把一张CAD图中所有圆心坐标列出来，不知那位大虾能指点一二？因为每个圆都有一个编号，最好能做到根据编号把坐标一一列出。

水炮眼大侠

这有何难,用getboundingbox取得两角点,利用两角点取得中心点坐标,然后用GREATEOBJECT与EXCEL建立连接就可以了,当然怎么做简单,但具体做"晕啊!晕啊!晕晕啊!

zml84

'1楼所说的编号，是指对象句柄？
'还是在对象上附加数据所记录的编号？

'2楼所讲思路正确。
'但取得圆心的方法过于曲折，要得到圆心坐标用
'“圆实体的CENTER属性” 则更为直接。

'根据1楼的意思，写了一个东西如下。
'虽然不完整，但已能说明问题了。

Sub ctoe()
Dim Excel As Excel.Application
Dim excelsheet As Object
Dim excelworkbook As Object

Dim rownum As Integer
Dim Found As Boolean
Dim MyObject As AcadEntity
Dim array1 As Variant
Dim count As Integer

'启动EXCEL
Set Excel = New Excel.Application

'创建workbook对象 并激活工作薄
Set excelworkbook = Excel.Workbooks.Add
Set excelsheet = Excel.ActiveSheet

rownum = 1
Found = False

'在模型空间中查找所有的圆图元
For Each MyObject In ThisDrawing.ModelSpace
    If StrComp(MyObject.EntityName, "acdbcircle", 1) = 0 Then '如果对象是圆
        '至此，圆对象MyObject就到了你的手中，可以得到：
        'myobject.center(0 to 2)          圆心坐标（数组）
        'myobject.radius                      半径
        'myobject.AREA                      面积
        'myobject.circumference         周长
        '....
                '如何组织数据写入EXCEL就随你的便了。
        rownum = rownum + 1
        Found = True    ' 将变量 Found 的值设成 True。
    End If
Next MyObject '遍历下一个对象

if found = true then excelworkbook.SaveAs "1圆心表"
Excel.Application.Quit
End Sub

*-*9

zwl2929

也许我太菜了，现请教如下
1、把上述代码运行是怎么第一行就出错？Dim Excel As Excel.Application
提示如下：编译错误，用户定义类型是未定义的
2、上述代码好象没有汲及到编号问题，我们通常是这样做的，根据一张地形图，先建立一图层，按照要求布置好圆和编号，然后用捕捉方式把中点坐标手工记下来。如果编号不能与坐标一一对应，程序也就没有实用价值。如果是在对象上附加数据所记录的编号，是不是就没有办法做到上述功能？要做到上述功能要求怎么做呢（如何把圆和编号关联起来）？
3、'在模型空间中查找所有的圆图元
For Each MyObject In ThisDrawing.ModelSpace
If StrComp(MyObject.EntityName, "acdbcircle", 1) = 0 Then '如果对象是圆
'至此，圆对象MyObject就到了你的手中，可以得到：
'myobject.center(0 to 2) 圆心坐标（数组）
'myobject.radius 半径
'myobject.AREA 面积
'myobject.circumference 周长
是不是把EntityName改成center(0 to 2)就可改录圆心坐标？
4、'如何组织数据写入EXCEL就随你的便了。我只要求在EXCEL中有三列就行了，编号、 X坐标 、Y坐标
代码该如何写？

万望各位高手给于指点，我刚接触VBA不好意思。

zml84

我也是刚接触VBA，大家共同探讨
1、解决方法：工具菜单--》引用，选取“Microsoft Excel 9.0 object library”(版本号可能不同)

2、还是有点不太明白你所说的编号是什么意思？编号在什么地方表达出来？

3、MyObject.EntityName返回的值是当前图元的类型

4、按照你的意思，补充后代码如下：

2. 
   
3.   [FONT=courier new]
   
4. Sub ctoe()
   
5. Dim rownum As Integer
   
6. Dim Found As Boolean
   
7. Dim MyObject As AcadEntity
   
8. 
   
9. rownum = 2
   
10. Found = False
    
11. For Each MyObject In ThisDrawing.ModelSpace               '在模型空间中遍历所有的图元
    
12.         If StrComp(MyObject.EntityName, "acdbcircle", 1) = 0 Then '这一句是判断对象是否是圆
    
13.                
    
14.                 If rownum = 2 Then '若是圆对象
    
15.                         Dim Excel As Excel.Application
    
16.                         Dim ExcelWorkbook As Object
    
17.                         Dim ExcelSheet As Object
    
18.                         Set Excel = New Excel.Application '启动EXCEL
    
19.                         Set ExcelWorkbook = Excel.Workbooks.Add
    
20.                         Set ExcelSheet = Excel.ActiveSheet
    
21.                         'Excel.Visible = True   '显示EXCEL
    
22.                         Dim pt '(0 To 2)   '定义数组变量，存储圆心坐标
    
23.                 End If
    
24.                
    
25.                 pt = MyObject.Center
    
26.                 ExcelSheet.Cells(rownum, 1) = "编号待定"
    
27.                 ExcelSheet.Cells(rownum, 2) = pt(0)                '圆心坐标X值
    
28.                 ExcelSheet.Cells(rownum, 3) = pt(1)                '圆心坐标Y值
    
29.                 ExcelSheet.Cells(rownum, 4) = pt(2)                '圆心坐标Z值
    
30.                 rownum = rownum + 1
    
31.                 Found = True '将标记设成 True。
    
32.         End If '结束IF
    
33. Next MyObject '遍历下一个对象
    
34. 
    
35. If Found = True Then
    
36.         ExcelSheet.Cells(1, 1) = "编号"
    
37.         ExcelSheet.Cells(1, 2) = "X"
    
38.         ExcelSheet.Cells(1, 3) = "Y"
    
39.         ExcelSheet.Cells(1, 4) = "Z"
    
40.         MsgBox "圆心坐标输出完毕，请检阅！"
    
41.         Excel.Visible = True   '显示EXCEL
    
42.         Set ExcelSheet = Nothing
    
43.         Set ExcelWorkbook = Nothing
    
44.         Set Excel = Nothing
    
45. Else
    
46.         MsgBox "在当前模型空间中未找到圆对象！"
    
47. End If
    
48. 
    
49. End Sub
    
50. 
    
51.   [/FONT]
    

<br />   [FONT=courier new]<br /> Sub ctoe()<br /> Dim rownum As Integer<br /> Dim Found As Boolean<br /> Dim MyObject As AcadEntity<br /> <br /> rownum = 2<br /> Found = False<br /> For Each MyObject In ThisDrawing.ModelSpace               '在模型空间中遍历所有的图元<br />         If StrComp(MyObject.EntityName, "acdbcircle", 1) = 0 Then '这一句是判断对象是否是圆<br />                 <br />                 If rownum = 2 Then '若是圆对象<br />                         Dim Excel As Excel.Application<br />                         Dim ExcelWorkbook As Object<br />                         Dim ExcelSheet As Object<br />                         Set Excel = New Excel.Application '启动EXCEL<br />                         Set ExcelWorkbook = Excel.Workbooks.Add<br />                         Set ExcelSheet = Excel.ActiveSheet<br />                         'Excel.Visible = True   '显示EXCEL<br />                         Dim pt '(0 To 2)   '定义数组变量，存储圆心坐标<br />                 End If<br />                 <br />                 pt = MyObject.Center<br />                 ExcelSheet.Cells(rownum, 1) = "编号待定"<br />                 ExcelSheet.Cells(rownum, 2) = pt(0)                '圆心坐标X值<br />                 ExcelSheet.Cells(rownum, 3) = pt(1)                '圆心坐标Y值<br />                 ExcelSheet.Cells(rownum, 4) = pt(2)                '圆心坐标Z值<br />                 rownum = rownum + 1<br />                 Found = True '将标记设成 True。<br />         End If '结束IF<br /> Next MyObject '遍历下一个对象<br /> <br /> If Found = True Then<br />         ExcelSheet.Cells(1, 1) = "编号"<br />         ExcelSheet.Cells(1, 2) = "X"<br />         ExcelSheet.Cells(1, 3) = "Y"<br />         ExcelSheet.Cells(1, 4) = "Z"<br />         MsgBox "圆心坐标输出完毕，请检阅！"<br />         Excel.Visible = True   '显示EXCEL<br />         Set ExcelSheet = Nothing<br />         Set ExcelWorkbook = Nothing<br />         Set Excel = Nothing<br /> Else<br />         MsgBox "在当前模型空间中未找到圆对象！"<br /> End If<br /> <br /> End Sub<br /> <br />   [/FONT]<br />

*-*9

唐僧肉

刚刚编了一段代码，做桩位图效果还形。带编号，同时按照坐标排序。

'唐僧肉写于2006.9.19
'得到园族的圆心坐标，并输入excel
'**************************
Sub cen()
'创建选择集
    On Error GoTo Err_Control
    Dim PI As Double: PI = Atn(1) * 4
    Dim sSetObj, sSetObj2 As AcadSelectionSet
    Dim gpCode(0) As Integer
    Dim dataValue(0) As Variant
    Dim groupCode As Variant, dataCode As Variant
    Dim PNT As Variant
    Dim Pnt1(0 To 2) As Double: Pnt1(0) = 0: Pnt1(1) = 0: Pnt1(2) = 0
   
    Dim centP As Variant
    Dim I As Integer: I = 0
    Dim A As Integer: A = 0
   
    Dim txtObj As AcadText

    Dim n As Integer
    Dim newUCS As AcadUCS
    Dim CurrUCS As AcadUCS
    Dim PILe_NUM, Pnum As String

    Pnum = InputBox("输入墩号", 墩号, "1")
'    Set sSetObj = ThisDrawing.SelectionSets.Add("SSET")

For A = 1 To 2
    If A = 1 Then
            PILe_NUM = "Z" & Pnum & "左"
        Else
            PILe_NUM = "Z" & Pnum & "右"
    End If
   
    Set sSetObj = ThisDrawing.SelectionSets.Add("SSET3")
    gpCode(0) = 0
    dataValue(0) = "circle"
    groupCode = gpCode
    dataCode = dataValue
    sSetObj.SelectOnScreen groupCode, dataCode
    n = sSetObj.Count

    If n = 0 Then Err.Raise 1, , "未选择任何物体!"
    ReDim centP(n * 3 - 1)
   
    If ThisDrawing.GetVariable("UCSNAME") = "" Then
        With ThisDrawing
            Set CurrUCS = .UserCoordinateSystems.Add( _
                            Pnt1, _
                            .GetVariable("UCSXDIR"), _
                            .GetVariable("UCSYDIR"), _
                            "OriginalUCS")
            CurrUCS.Origin = .GetVariable("UCSORG")
            
        End With
        
        For I = 0 To n - 1 Step 1
              PNT = ThisDrawing.Utility.TranslateCoordinates(sSetObj(I).Center, acWorld, acUCS, 0)
              centP(3 * I) = Round(PNT(0), 3)
              centP(3 * I + 1) = Round(PNT(1), 3)
              centP(3 * I + 2) = Round(PNT(2), 3)
             'Debug.Print centP(3 * I); centP(3 * I + 1); centP(3 * I + 2); Spc(3)
        Next I
        Call SSortXYZ(centP, "x")
        Call OnlySortxyzUP(centP, "y")
        For I = 0 To n - 1 Step 1
            PNT(0) = Round(centP(3 * I), 3)
            PNT(1) = Round(centP(3 * I + 1), 3)
            PNT(2) = Round(centP(3 * I + 2), 3)
              PNT = ThisDrawing.Utility.TranslateCoordinates(PNT, acUCS, acWorld, 0)
'            Debug.Print PNT(0)
'            Debug.Print PNT(1)
'            Debug.Print PNT(2)
              centP(3 * I) = Round(PNT(0), 3)
              centP(3 * I + 1) = Round(PNT(1), 3)
              centP(3 * I + 2) = Round(PNT(2), 3)
            Set txtObj = ThisDrawing.ModelSpace.AddText("桩位" & CStr(I + 1), PNT, 0.5)
        Next I
    Else
        Set CurrUCS = ThisDrawing.ActiveUCS  'current UCS is saved
        For I = 0 To n - 1 Step 1
              PNT = ThisDrawing.Utility.TranslateCoordinates(sSetObj(I).Center, acWorld, acUCS, 0)
              centP(3 * I) = Round(PNT(0), 3)
              centP(3 * I + 1) = Round(PNT(1), 3)
              centP(3 * I + 2) = Round(PNT(2), 3)
              Debug.Print centP(3 * I); centP(3 * I + 1); centP(3 * I + 2); Spc(3)
        Next I
        Call SSortXYZ(centP, "x")
        Call OnlySortxyzUP(centP, "y")
        For I = 0 To n - 1 Step 1
            PNT(0) = Round(centP(3 * I), 3)
            PNT(1) = Round(centP(3 * I + 1), 3)
            PNT(2) = Round(centP(3 * I + 2), 3)
            PNT = ThisDrawing.Utility.TranslateCoordinates(PNT, acWorld, acUCS, 0)

            Set txtObj = ThisDrawing.ModelSpace.AddText("桩位" & CStr(I + 1), PNT, 0.5)
        Next I
    End If
    Call Cad2Xls(PILe_NUM, centP, n)
     
     
ThisDrawing.SelectionSets.Item("SSET3").Delete
Next A
     
     
     
'容错处理
Exit_Here:
  'sSetObj.Delete
  Exit Sub
Err_Control:
  MsgBox Err.Description
  'Resume Exit_Here
  'sSetObj.Delete
End Sub

Sub Cad2Xls(ByVal PILe_NUM As String, ByVal PNT As Variant, n As Integer)

    'On Error Resume Next
    Dim xlApp As Excel.Application
    Set xlApp = GetObject(, "Excel.Application")
    If Err Then
        MsgBox " Excel 没有运行。"
        Exit Sub
    End If
    Dim xlSht As Worksheet
    Set xlSht = xlApp.ActiveSheet
    Dim BlockObj As AcadBlock
    Set BlockObj = ThisDrawing.Blocks("*Model_Space")
    Dim xlRange As Range
    Dim RngCol As Integer
    Dim RngRow As Double
    Dim ColRow As Double
    RngCol = xlSht.UsedRange.Columns.Count
    If RngCol = 1 Then RngCol = 0
    'RngRow = xlSheet.UsedRange.Rows.Count
  ' Debug.Print UBound(PNT)
   ' Debug.Print RngCol


'******************************************************************
        For I = 0 To n - 1 Step 1
            'PNT = ThisDrawing.Utility.TranslateCoordinates(PNT, acWorld, acUCS, 0)
            If I = 0 Then
                    xlSht.Cells(I + 1, RngCol + 1).Value = PILe_NUM
                    xlSht.Cells(I + 1, RngCol + 2).Value = "x坐标"
                    xlSht.Cells(I + 1, RngCol + 3).Value = "y坐标"
               
               End If
            
            xlSht.Cells(I + 2, RngCol + 1).Value = "桩位" & CStr(I + 1)
            xlSht.Cells(I + 2, RngCol + 2).Value = PNT(3 * I + 1) 'x坐标
            xlSht.Cells(I + 2, RngCol + 3).Value = PNT(3 * I) 'Y坐标
        Next I

   ' RngCol = xlSht.UsedRange.Columns.Count
    'Debug.Print RngCol
    Set xlRange = Nothing
    Set xlSht = Nothing
    Set xlApp = Nothing

End Sub





'对text对象的 x或 y或 z坐标排序
'调用本子例程时,用call tsortxyz(pnt,"x")
'""号内字符分别对应x,y,z坐标
'返回排完序后的3维点集及字符串
'排列顺序由大到小
Sub TSortXYZ(PNT, XYZ As String)
Dim I, J, K As Integer
Dim Val, Val1, Val2 As Double
Dim Str As String

Select Case XYZ
Case "x"
   For I = LBound(PNT) To UBound(PNT) - 1 Step 4
       K = I + 4
          For J = K To UBound(PNT) Step 4
              If PNT(I) < PNT(J) Then
                 Val = PNT(I): Val1 = PNT(I + 1): Val2 = PNT(I + 2): Str = PNT(I + 3)
                 PNT(I) = PNT(J): PNT(I + 1) = PNT(J + 1): PNT(I + 2) = PNT(J + 2): PNT(I + 3) = PNT(J + 3)
                 PNT(J) = Val: PNT(J + 1) = Val1: PNT(J + 2) = Val2: PNT(J + 3) = Str
              End If
          Next J
   Next I

Case "y"
   For I = LBound(PNT) + 1 To UBound(PNT) - 1 Step 4
       K = I + 4
          For J = K To UBound(PNT) Step 4
              If PNT(I) < PNT(J) Then
                 Val = PNT(I - 1): Val1 = PNT(I): Val2 = PNT(I + 1): Str = PNT(I + 2)
                 PNT(I - 1) = PNT(J - 1): PNT(I) = PNT(J): PNT(I + 1) = PNT(J + 1): PNT(I + 2) = PNT(J + 2)
                 PNT(J - 1) = Val: PNT(J) = Val1: PNT(J + 1) = Val2: PNT(J + 2) = Str
              'Debug.Print Str
              End If
          Next J
   Next I

Case "z"
   For I = LBound(PNT) + 2 To UBound(PNT) - 1 Step 4
       K = I + 4
          For J = K To UBound(PNT) Step 4
              If PNT(I) < PNT(J) Then
                 Val = PNT(I - 2): Val1 = PNT(I - 1): Val2 = PNT(I): Str = PNT(I + 1)
                 PNT(I - 2) = PNT(J - 2): PNT(I - 1) = PNT(J - 1): PNT(I) = PNT(J): PNT(I + 1) = PNT(J + 1)
                 PNT(J - 2) = Val: PNT(J - 1) = Val1: PNT(J) = Val2: PNT(J + 1) = Str
              End If
          Next J
   Next I
End Select

End Sub


'对 x或 y或 z坐标排序
'调用本子例程时,用call Ssortxyz(pnt,"x")
'""号内字符分别对应x,y,z坐标
'返回排完序后的3维点集
'排列顺序由小到大
Sub SSortXYZ(PNT, XYZ As String)
Dim I, J, K As Integer
Dim Val, Val1, Val2 As Double

Select Case XYZ
Case "x"
   For I = LBound(PNT) To UBound(PNT) - 1 Step 3
       K = I + 3
          For J = K To UBound(PNT) Step 3
              If PNT(I) > PNT(J) Then
                 Val = PNT(I): Val1 = PNT(I + 1): Val2 = PNT(I + 2)
                 PNT(I) = PNT(J): PNT(I + 1) = PNT(J + 1): PNT(I + 2) = PNT(J + 2)
                 PNT(J) = Val: PNT(J + 1) = Val1: PNT(J + 2) = Val2
              End If
          Next J
   Next I

Case "y"
   For I = LBound(PNT) + 1 To UBound(PNT) - 1 Step 3
       K = I + 3
          For J = K To UBound(PNT) Step 3
              If PNT(I) > PNT(J) Then
                 Val = PNT(I - 1): Val1 = PNT(I): Val2 = PNT(I + 1)
                 PNT(I - 1) = PNT(J - 1): PNT(I) = PNT(J): PNT(I + 1) = PNT(J + 1)
                 PNT(J - 1) = Val: PNT(J) = Val1: PNT(J + 1) = Val2
              End If
          Next J
   Next I

Case "z"
   For I = LBound(PNT) + 2 To UBound(PNT) - 1 Step 3
       K = I + 3
          For J = K To UBound(PNT) Step 3
              If PNT(I) > PNT(J) Then
                 Val = PNT(I - 2): Val1 = PNT(I - 1): Val2 = PNT(I)
                 PNT(I - 2) = PNT(J - 2): PNT(I - 1) = PNT(J - 1): PNT(I) = PNT(J)
                 PNT(J - 2) = Val: PNT(J - 1) = Val1: PNT(J) = Val2
              End If
          Next J
   Next I
End Select

End Sub


'例如对  y坐标排序,x 坐标不动
'调用本子例程时,用call Ssortxyz(pnt,"x")
'""号内字符分别对应x,y,z坐标
'返回排完序后的3维点集
'排列顺序由小到大
Sub OnlySortxyzLow(PNT, XYZ As String)
Dim I, J, K As Integer
Dim Val, Val1, Val2 As Double

Select Case XYZ
Case "x"
   For I = LBound(PNT) To UBound(PNT) - 1 Step 3
       K = I + 3
          For J = K To UBound(PNT) Step 3
          If PNT(I - 1) = PNT(J - 1) Then
              If PNT(I) > PNT(J) Then
                 Val = PNT(I): Val1 = PNT(I + 1): Val2 = PNT(I + 2)
                 PNT(I) = PNT(J): PNT(I + 1) = PNT(J + 1): PNT(I + 2) = PNT(J + 2)
                 PNT(J) = Val: PNT(J + 1) = Val1: PNT(J + 2) = Val2
              End If
          Else
              GoTo 10
          End If
10        Next J
   Next I
'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Case "y"
   For I = LBound(PNT) + 1 To UBound(PNT) - 1 Step 3
       K = I + 3
      
          For J = K To UBound(PNT) Step 3
          If PNT(I - 1) = PNT(J - 1) Then
              If PNT(I) > PNT(J) Then
                 Val = PNT(I - 1): Val1 = PNT(I): Val2 = PNT(I + 1)
                 PNT(I - 1) = PNT(J - 1): PNT(I) = PNT(J): PNT(I + 1) = PNT(J + 1)
                 PNT(J - 1) = Val: PNT(J) = Val1: PNT(J + 1) = Val2
              End If
          Else
          GoTo 20
          End If
20          Next J
   
   
   Next I
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Case "z"
   For I = LBound(PNT) + 2 To UBound(PNT) - 1 Step 3
       K = I + 3
          For J = K To UBound(PNT) Step 3
            If PNT(I - 1) = PNT(J - 1) Then
                If PNT(I) > PNT(J) Then
                   Val = PNT(I - 2): Val1 = PNT(I - 1): Val2 = PNT(I)
                   PNT(I - 2) = PNT(J - 2): PNT(I - 1) = PNT(J - 1): PNT(I) = PNT(J)
                   PNT(J - 2) = Val: PNT(J - 1) = Val1: PNT(J) = Val2
                End If
            Else
                GoTo 30
            End If
30        Next J
   Next I
End Select

End Sub '例如对  y坐标排序,x 坐标不动
'调用本子例程时,用call Ssortxyz(pnt,"x")
'""号内字符分别对应x,y,z坐标
'返回排完序后的3维点集
'排列顺序由大到小
Sub OnlySortxyzUP(PNT, XYZ As String)
Dim I, J, K As Integer
Dim Val, Val1, Val2 As Double

Select Case XYZ
Case "x"
   For I = LBound(PNT) To UBound(PNT) - 1 Step 3
       K = I + 3
          For J = K To UBound(PNT) Step 3
          If PNT(I - 1) = PNT(J - 1) Then
              If PNT(I) < PNT(J) Then
                 Val = PNT(I): Val1 = PNT(I + 1): Val2 = PNT(I + 2)
                 PNT(I) = PNT(J): PNT(I + 1) = PNT(J + 1): PNT(I + 2) = PNT(J + 2)
                 PNT(J) = Val: PNT(J + 1) = Val1: PNT(J + 2) = Val2
              End If
          Else
              GoTo 10
          End If
10        Next J
   Next I
'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Case "y"
   For I = LBound(PNT) + 1 To UBound(PNT) - 1 Step 3
       K = I + 3
      
          For J = K To UBound(PNT) Step 3
          If PNT(I - 1) = PNT(J - 1) Then
              If PNT(I) < PNT(J) Then
                 Val = PNT(I - 1): Val1 = PNT(I): Val2 = PNT(I + 1)
                 PNT(I - 1) = PNT(J - 1): PNT(I) = PNT(J): PNT(I + 1) = PNT(J + 1)
                 PNT(J - 1) = Val: PNT(J) = Val1: PNT(J + 1) = Val2
              End If
          Else
          GoTo 20
          End If
20          Next J
   
   
   Next I
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Case "z"
   For I = LBound(PNT) + 2 To UBound(PNT) - 1 Step 3
       K = I + 3
          For J = K To UBound(PNT) Step 3
            If PNT(I - 1) = PNT(J - 1) Then
                If PNT(I) < PNT(J) Then
                   Val = PNT(I - 2): Val1 = PNT(I - 1): Val2 = PNT(I)
                   PNT(I - 2) = PNT(J - 2): PNT(I - 1) = PNT(J - 1): PNT(I) = PNT(J)
                   PNT(J - 2) = Val: PNT(J - 1) = Val1: PNT(J) = Val2
                End If
            Else
                GoTo 30
            End If
30        Next J
   Next I
End Select

End Sub

Function test()
    ' Begin the selection
    Dim returnObj As AcadObject
    Dim basePnt As Variant
   
    On Error Resume Next
   
    ' The following example waits for a selection from the user

RETRY:
    ThisDrawing.Utility.GetEntity returnObj, basePnt, "Select an object"
   
    If Err <> 0 Then
        Err.Clear
        MsgBox "Program ended.", , "GetEntity Example"
        Exit Function
    Else
        returnObj.Update
        MsgBox "The object type is: " & returnObj.EntityName, , "GetEntity Example"
        returnObj.Update
    End If
   
    GoTo RETRY
pointUCS = ThisDrawing.Utility.TranslateCoordinates(pointWCS, acWorld, acUCS, False)

End Function

zwl2929

真是太感谢二位了，看来我要好好消化消化再说。
我说的编号就是在圆附近用字母或者数字注明的一个代号，应该是你说的在对象上附加数据所记录的编号的意思吧。（通常圆与圆之间都有一定距离不会重合在一起）上述代码应该不能把编号读入吧，有人告诉我编号应该根据圆心坐标在一定范围入查找，并一起读入，我也不知该用什么代码才能实现上述功能。

zml84

1、如果编号已文本的方式写在圆内的话，可以在得到圆心坐标后，用窗选的方法在圆内选择实体；尔后，分析是否有文字实体被选中；若有且只有一个，则将其写入。

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里面如何用代码来实现我就不知如何下手了，高手请多指点

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

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

但在例子2中在EXCEL中编号为什么会变成
{\fArial|b0|i0|c0|p32;z1}、  {\fArial|b0|i0|c0|p32;z2}又要如何才能解决例子2中的编号问题？

zml84

9楼：
1、关于排序问题。我现没看你的附件。我的想法是：既然是桩位坐标-------->那么编号在本图中应该是唯一的--------->那么则可以在EXCEL中以编号作为行号进行存储。这样一来就没有排序的麻烦了。
2、编号内容出现诸如"{\fArial|b0|i0|c0|p32;z1}"、"{\fArial|b0|i0|c0|p32;z2}"等内容，是因为多行文本的内容中可以使用控制选项。解决方法有二：要么将其打散（仅仅编号的话确实没有使用多行文本的必要）；要么在提取文本内容时，将控制选项内容处理后再写入EXCEL。

*-*9

zhuwy16

对我来说很有帮助阿
谢谢大家

tnt1095

谢谢

jx2008

谢谢，以前我下载过一个，很好用，不是VBA的，就是要一个一个的选择，有点麻烦，改天上传给大家

yqq0101

我运行时为何出现编译错误：找不到工程或库？

xingchao1350

非常有用，正在做桩编号，用得到