用VBA将图层信息输出到EXCEL的方法

woaishuijia

使用方法：“Alt+F11”打开“VBA编辑器”，单击“工具”菜单，单击“引用”，在弹出的“引用－ACADObject”对话框中寻找并选中Microsoft Excel类型库(比如本机安装的Excel是2000版，引用的类型库就是“Microsoft Excel 9.0 Object Library”)。“确定”后退出对话框。双击“工程资源管理器”中的“ThisDrawing”对象，在弹出的代码窗口粘贴下面代码，“F5”运行。
, i8 u1 Q& v% W  U9 M3 m
% s1 ?  |2 ?2 x( d- B4 \0 {''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
, Y4 x3 {: y0 S* M" H' P% y6 CSub TC()
- {, Q8 [  X) y: Y) F4 ~3 r    Dim R As Integer, C As Integer, I As Integer, Ly As AcadLayer
    Dim xlApp As Excel.Application, xlBook As Excel.Workbook
   
    R = 1: C = 1 '从工作表的第1行第1列开始填写，使用者自行更改
   
    Set xlApp = CreateObject("Excel.Application") '打开EXCEL程序
$ x, }) K2 {) u, `7 S1 C: e    xlApp.Visible = True '使EXCEL程序可见
, b: F; B- l$ p3 R    Set xlBook = xlApp.Workbooks.Add '插入新工作薄
    With xlBook.ActiveSheet
        .Name = "图层信息" '重命名当前工作表
        I = R
8 F0 \% A1 T/ \+ ^4 p3 A        .Range(.Cells(I, C), .Cells(I, C + 11)).HorizontalAlignment = xlCenter  '所有填写项目名称的单元格水平中心对齐
2 K# X% W2 M, u2 d& ^        .Cells(I, C).Value = "序号"  '以下代码逐列填写项目名称
        .Cells(I, C + 1).Value = "状态"
        .Cells(I, C + 2).Value = "名称"
        .Cells(I, C + 3).Value = "开关"
# n$ N* m- w& i4 M/ k4 _: w( P        .Cells(I, C + 4).Value = "冻结"
6 }" y8 V5 F. R2 o" j1 r! O$ s        .Cells(I, C + 5).Value = "锁定"
        .Cells(I, C + 6).Value = "颜色"
        .Cells(I, C + 7).Value = "线型"
# I7 N* o: D5 t7 [( X        .Cells(I, C + 8).Value = "线宽"
% E$ M" b* g$ J3 }5 C2 z& S        .Cells(I, C + 9).Value = "打印样式"
        .Cells(I, C + 10).Value = "打印"
        .Cells(I, C + 11).Value = "说明"
; n& Z0 |% M& a, u  o  L2 z        For Each Ly In ThisDrawing.Layers '遍历图层
6 B! o( \8 \9 c            I = I + 1 '在下一行填写该图层信息
1 H2 f4 i! G# f2 d0 }( s; c* z            .Range(.Cells(I, C), .Cells(I, C + 10)).HorizontalAlignment = xlCenter  '前11项信息所在单元格水平中心对齐
            .Cells(I, C + 11).HorizontalAlignment = xlLeft '填写图层说明的单元格水平左对齐
8 q3 ]; u1 t( U* x) y            .Cells(I, C).Value = I - 1  '在第1列填写序号
9 Z5 t% k4 W% `& ^, q* a, y  h            If Ly.Used Then .Cells(I, C + 1).Value = "已使用" Else .Cells(I, C + 1).Value = "未使用" '第2列填写使用状态
% H( q$ o- f% g/ S            .Cells(I, C + 2).Value = Ly.Name '第3列填写图层名称
            If Ly.LayerOn Then .Cells(I, C + 3).Value = "开" Else .Cells(I, C + 3).Value = "关" '第4列填写开关状态
) e/ t" ^7 f) D/ x8 c! A! N            If Ly.Freeze Then .Cells(I, C + 4).Value = "已冻结" Else .Cells(I, C + 4).Value = "未冻结" '第5列填写冻结状态
- k  q! _3 i% |- A9 k3 s" W            If Ly.Lock Then .Cells(I, C + 5).Value = "已锁定" Else .Cells(I, C + 5).Value = "未锁定" '第6列填写锁定状态
            Select Case Ly.TrueColor.ColorMethod '检查颜色定义的方法
, t0 _4 K0 J( a2 C+ ~" a+ ^* p( Y                Case 194 '该图层颜色定义为RGB颜色时，在第7列填写RGB颜色
                    .Cells(I, C + 6).Value = "RGB颜色" & Ly.TrueColor.Red & "," & Ly.TrueColor.Green & "," & Ly.TrueColor.Blue
: V' c/ K/ u! R                Case 195 '该图层颜色定义为索引颜色时
                    Select Case Ly.TrueColor.ColorIndex
1 l8 _) H2 x- j# Z, c+ }1 S. |                        Case 1 '以下代码按索引号在第7列填写颜色名称
7 Z9 `5 a+ S. R7 Z, R; y. Y  P                            .Cells(I, C + 6).Value = "红"
                        Case 2
                            .Cells(I, C + 6).Value = "黄"
                        Case 3
4 @( n, V( V: C7 d* h5 M: n' [                            .Cells(I, C + 6).Value = "绿"
1 W- t# q1 L: A                        Case 4
  q/ ?$ w4 v; O% m) U2 ^                            .Cells(I, C + 6).Value = "青"
                        Case 5
" [5 z( A: v! e# T                            .Cells(I, C + 6).Value = "蓝"
                        Case 6
% T' Z$ w' I4 r' x. K/ u! t                            .Cells(I, C + 6).Value = "洋红"
! h. L/ _! f" r. z' f$ x, U. n                        Case 7
1 I& ^* R( W' B& V) G                            .Cells(I, C + 6).Value = "白"
& [4 n: G2 Z" |4 h4 {) J6 ~                        Case Else '无名称的索引颜色在第7列填写索引号
! [" L; b& ~5 C7 e! q* _                            .Cells(I, C + 6).Value = "索引颜色" & Ly.TrueColor.ColorIndex
8 }4 X7 d$ f* f7 c2 N  M5 F, G                    End Select
; ?/ N6 a- v( e: F            End Select
            .Cells(I, C + 7).Value = Ly.Linetype '第8列填写线型名称
3 z9 }6 o8 L4 w% t0 t* ?            Select Case Ly.Lineweight '第9列填写线宽
) u' y% ~3 k7 c                Case -3 '
; M& V, K' A" D/ m1 }                    .Cells(I, C + 8).Value = "默认"
                Case Else
                    .Cells(I, C + 8).Value = Val(Ly.Lineweight) / 100
2 g. N. J3 J8 O            End Select
  J: ?0 I& M) f. ~4 U6 y4 @$ H            .Cells(I, C + 9).Value = Ly.PlotStyleName '第10列填写打印样式名称
5 E+ f) a! L0 ]( L& E7 h( `            If Ly.Plottable Then .Cells(I, C + 10).Value = "打印" Else .Cells(I, C + 10).Value = "不打印" '第11列填写是否打印
            .Cells(I, C + 11).Value = Ly.Description '第12列填写图层说明
) o( L9 S1 g- H7 l        Next
        .Range(.Cells(R, C), .Cells(I, C + 11)).Columns.AutoFit '最适合的列宽
7 S* g3 N. [9 J5 f4 K    End With
& D- ~# H* X9 s+ h; P- i( TEnd Sub
6 ?! f' s# U  y; Z% ~7 F'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
4 Z! s% O# ]1 V! V
运行结果

sailinggirl

感谢，楼主辛苦了

great829

谢谢楼主，参考了，我再试试VC++编这种程序

64400732

谢谢楼主，参考了，厉害

kinatec

感谢楼主分享! Ding

spidow

这个都可以写出来，佩服。。

u47321111

很好。可以借用修改用于其他程序转化成excel输出。感谢lz。

baby008

不错不错  厉害