[讨论]如何提取到CAD数据的

Sub als()
   Dim xm, xm1
   Dim tt As AcadText, ll As AcadLine, Ent As AcadEntity
   aii = 0
   ReDim xm(1000) As Double, xm1(1000) As Long
   For Each Ent In ThisDrawing.ModelSpace
     Select Case Ent.ObjectName
       Case "AcDbLine"
         Set ll = Ent
         xm(aii) = Round(ll.EndPoint(0), 3)
         'Debug.Print xm(aii)
         xm1(aii) = ll.EndPoint(1)
         aii = aii + 1
      End Select
   Next Ent
   ReDim Preserve xm(aii) As Double
   bb = xx(xm)
   bb = Bubble_Sort(bb)
   ReDim abc(UBound(bb)) As Long
   For ii = 0 To UBound(bb)
     'abc(ii) = Val(bb(ii))
     Debug.Print ii, bb(ii)
   Next ii
   
   
   
   ReDim xm(0), xm1(0)
End Sub
     
Function xx(xm)
   Dim arr() As String, Temp() As String '声明变量
   Dim s%, r% '声明单值变量
     On Error Resume Next '启动一个错误处理程序
     
     r = 0 '初值
     s = UBound(xm)  '最大下标
     
     For i = 0 To s '循环
       Temp = Filter(arr, xm(i)) '搜索数组
       
       If UBound(Temp) = -1 Then '如果未找到
         ReDim Preserve arr(0 To r)  '定义动态数组大小
         arr(r) = xm(i) '把姓名复制到数组Arr()中。
         r = r + 1 '序号，自增1
       End If
     Next
     xx = arr
End Function
Function Bubble_Sort(Ary)
   Dim aryUBound, i, j
   aryUBound = UBound(Ary)
   For ii = 0 To aryUBound
     Ary(ii) = Val(Round(Ary(ii), 2))
   Next ii
   For i = 0 To aryUBound
     For j = i + 1 To aryUBound
       If Ary(i) < Ary(j) Then
         Swap Ary(i), Ary(j)
       End If
     Next
   Next
   Bubble_Sort = Ary
End Function
Function Swap(a, b)
   Dim tmp
   tmp = a
   a = b
   b = tmp
End Function