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

muwind

我用过的一个清单提取程序,在不打开DWG文件的情况下,对CAD的数据进行处理,进而读取文件明细栏里数据,并把数据保存为MDB格式.程序会自动判断DWG是否有明细栏,有的会把他列为装配件并提示出安装图(也就是要图发到现场给安装的人用的),我猜想是程序首先读取了文件里一些基本信息,比如图副,比例等,进而知道图签的位置高度,再确定是否有明细栏.当然也要读取图签里的数据,图号,图纸名称等等(生成图纸目录需要的).程序还会根据装配件的图号判断该图是否存在,存在就展开,不存在则出现错误提示.很想知道这个东西是怎么读取信息,请知道的指点下.先行谢谢了

兰州人

2. Sub als()
3.    Dim xm, xm1
4.    Dim tt As AcadText, ll As AcadLine, Ent As AcadEntity
5.    aii = 0
6.    ReDim xm(1000) As Double, xm1(1000) As Long
7.    For Each Ent In ThisDrawing.ModelSpace
8.      Select Case Ent.ObjectName
9.        Case "AcDbLine"
10.          Set ll = Ent
11.          xm(aii) = Round(ll.EndPoint(0), 3)
12.          'Debug.Print xm(aii)
13.          xm1(aii) = ll.EndPoint(1)
14.          aii = aii + 1
15.       End Select
16.    Next Ent
17.    ReDim Preserve xm(aii) As Double
18.    bb = xx(xm)
19.    bb = Bubble_Sort(bb)
20.    ReDim abc(UBound(bb)) As Long
21.    For ii = 0 To UBound(bb)
22.      'abc(ii) = Val(bb(ii))
23.      Debug.Print ii, bb(ii)
24.    Next ii
25.    
26.    
27.    
28.    ReDim xm(0), xm1(0)
29. End Sub
30.      
31. Function xx(xm)
32.    Dim arr() As String, Temp() As String '声明变量
33.    Dim s%, r% '声明单值变量
34.      On Error Resume Next '启动一个错误处理程序
35.      
36.      r = 0 '初值
37.      s = UBound(xm)  '最大下标
38.      
39.      For i = 0 To s '循环
40.        Temp = Filter(arr, xm(i)) '搜索数组
41.       
42.        If UBound(Temp) = -1 Then '如果未找到
43.          ReDim Preserve arr(0 To r)  '定义动态数组大小
44.          arr(r) = xm(i) '把姓名复制到数组Arr()中。
45.          r = r + 1 '序号，自增1
46.        End If
47.      Next
48.      xx = arr
49. End Function
50. Function Bubble_Sort(Ary)
51.    Dim aryUBound, i, j
52.    aryUBound = UBound(Ary)
53.    For ii = 0 To aryUBound
54.      Ary(ii) = Val(Round(Ary(ii), 2))
55.    Next ii
56.    For i = 0 To aryUBound
57.      For j = i + 1 To aryUBound
58.        If Ary(i) < Ary(j) Then
59.          Swap Ary(i), Ary(j)
60.        End If
61.      Next
62.    Next
63.    Bubble_Sort = Ary
64. End Function
65. Function Swap(a, b)
66.    Dim tmp
67.    tmp = a
68.    a = b
69.    b = tmp
70. End Function

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