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