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

woaishuijia

使用方法：“Alt+F11”打开“VBA编辑器”，单击“工具”菜单，单击“引用”，在弹出的“引用－ACADObject”对话框中寻找并选中Microsoft Excel类型库(比如本机安装的Excel是2000版，引用的类型库就是“Microsoft Excel 9.0 Object Library”)。“确定”后退出对话框。双击“工程资源管理器”中的“ThisDrawing”对象，在弹出的代码窗口粘贴下面代码，“F5”运行。

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub TC()
    Dim R As Integer, C As Integer, I As Integer, Ly As AcadLayer
    Dim xlApp As Excel.Application, xlBook As Excel.Workbook
4 t" [, U0 w  E: \, p2 N) R: X   
7 F9 K6 a: j8 m    R = 1: C = 1 '从工作表的第1行第1列开始填写，使用者自行更改
; u( q# o( s# T2 x5 P, W   
    Set xlApp = CreateObject("Excel.Application") '打开EXCEL程序
' ]  Z' m6 z2 d* j    xlApp.Visible = True '使EXCEL程序可见
    Set xlBook = xlApp.Workbooks.Add '插入新工作薄
    With xlBook.ActiveSheet
4 |* D; a) }: ?1 K$ A/ `6 ]0 c* u  r+ ]        .Name = "图层信息" '重命名当前工作表
) o% [$ g1 j' j; {        I = R
        .Range(.Cells(I, C), .Cells(I, C + 11)).HorizontalAlignment = xlCenter  '所有填写项目名称的单元格水平中心对齐
/ h( K  O( @, o! I3 s" h8 w- L* l        .Cells(I, C).Value = "序号"  '以下代码逐列填写项目名称
. y$ V/ V* t9 X        .Cells(I, C + 1).Value = "状态"
4 B; C5 L* k5 t+ y/ R9 E# R$ Y4 `, p        .Cells(I, C + 2).Value = "名称"
        .Cells(I, C + 3).Value = "开关"
% V& J/ P. n' e; B        .Cells(I, C + 4).Value = "冻结"
5 ^. C1 Z& Y; g/ I# z% q        .Cells(I, C + 5).Value = "锁定"
, u5 V# e1 a0 n. N0 [2 J7 _) q        .Cells(I, C + 6).Value = "颜色"
        .Cells(I, C + 7).Value = "线型"
        .Cells(I, C + 8).Value = "线宽"
8 U6 ^# Z, h, g6 R; I        .Cells(I, C + 9).Value = "打印样式"
        .Cells(I, C + 10).Value = "打印"
% J: Y) y$ u( E, H# o5 R$ p        .Cells(I, C + 11).Value = "说明"
' C: x8 \3 V  ~$ a' ^        For Each Ly In ThisDrawing.Layers '遍历图层
& H# T& k" u% O9 v0 P/ R            I = I + 1 '在下一行填写该图层信息
% t/ I4 ^9 _! v            .Range(.Cells(I, C), .Cells(I, C + 10)).HorizontalAlignment = xlCenter  '前11项信息所在单元格水平中心对齐
            .Cells(I, C + 11).HorizontalAlignment = xlLeft '填写图层说明的单元格水平左对齐
$ A7 h+ {& [' \0 R- B            .Cells(I, C).Value = I - 1  '在第1列填写序号
; c9 ^: Z6 v- U& L4 S0 j; E; S            If Ly.Used Then .Cells(I, C + 1).Value = "已使用" Else .Cells(I, C + 1).Value = "未使用" '第2列填写使用状态
2 ?" f1 R3 F5 Q' O/ g0 ^            .Cells(I, C + 2).Value = Ly.Name '第3列填写图层名称
- Y& Y0 a: B! a! ]* J6 N            If Ly.LayerOn Then .Cells(I, C + 3).Value = "开" Else .Cells(I, C + 3).Value = "关" '第4列填写开关状态
            If Ly.Freeze Then .Cells(I, C + 4).Value = "已冻结" Else .Cells(I, C + 4).Value = "未冻结" '第5列填写冻结状态
% R. C& \/ X+ W' O9 I0 R, Y/ i2 C$ E: V            If Ly.Lock Then .Cells(I, C + 5).Value = "已锁定" Else .Cells(I, C + 5).Value = "未锁定" '第6列填写锁定状态
+ }3 n- O7 [$ d; \  r; D            Select Case Ly.TrueColor.ColorMethod '检查颜色定义的方法
                Case 194 '该图层颜色定义为RGB颜色时，在第7列填写RGB颜色
                    .Cells(I, C + 6).Value = "RGB颜色" & Ly.TrueColor.Red & "," & Ly.TrueColor.Green & "," & Ly.TrueColor.Blue
                Case 195 '该图层颜色定义为索引颜色时
                    Select Case Ly.TrueColor.ColorIndex
4 l0 \8 A- w; S/ D/ ^                        Case 1 '以下代码按索引号在第7列填写颜色名称
" n8 X" n; Z  [% t; I- w, b% I9 z                            .Cells(I, C + 6).Value = "红"
                        Case 2
8 x! D$ D' ], U; D5 n, e                            .Cells(I, C + 6).Value = "黄"
                        Case 3
                            .Cells(I, C + 6).Value = "绿"
7 k  L7 W3 C; m& `* @, ]: t+ s                        Case 4
4 c/ i7 M- v( t: ^7 D( x                            .Cells(I, C + 6).Value = "青"
( l' j! R5 H- Q1 _6 J                        Case 5
                            .Cells(I, C + 6).Value = "蓝"
                        Case 6
. V* g" k/ |% A( e5 w                            .Cells(I, C + 6).Value = "洋红"
) T' t; Z. H" Q& F" g' Y                        Case 7
                            .Cells(I, C + 6).Value = "白"
                        Case Else '无名称的索引颜色在第7列填写索引号
% M+ h- t; Z( ^5 p                            .Cells(I, C + 6).Value = "索引颜色" & Ly.TrueColor.ColorIndex
9 ?1 a1 r* O, |. u9 v                    End Select
3 p* F/ ~' @5 R  ~. _            End Select
0 \$ x" e  P8 p# X0 j; b& Q9 w            .Cells(I, C + 7).Value = Ly.Linetype '第8列填写线型名称
            Select Case Ly.Lineweight '第9列填写线宽
                Case -3 '
                    .Cells(I, C + 8).Value = "默认"
                Case Else
$ d0 P, e2 p7 U                    .Cells(I, C + 8).Value = Val(Ly.Lineweight) / 100
: E6 h% X, e# t            End Select
4 b& C& P3 E# Q$ T3 l" A            .Cells(I, C + 9).Value = Ly.PlotStyleName '第10列填写打印样式名称
            If Ly.Plottable Then .Cells(I, C + 10).Value = "打印" Else .Cells(I, C + 10).Value = "不打印" '第11列填写是否打印
            .Cells(I, C + 11).Value = Ly.Description '第12列填写图层说明
        Next
) \9 Q  Q  B9 R$ u        .Range(.Cells(R, C), .Cells(I, C + 11)).Columns.AutoFit '最适合的列宽
5 c$ v) o9 R& ^1 Q: Q    End With
3 t6 S9 f3 @; x/ `, {  G! P' VEnd Sub
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
& m; G6 w  \( u. b7 p
) `% ]3 I6 q% _( K) }运行结果
* K' g) d2 j! w$ K

sailinggirl

感谢，楼主辛苦了

great829

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

64400732

谢谢楼主，参考了，厉害

kinatec

感谢楼主分享! Ding

spidow

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

u47321111

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

baby008

不错不错  厉害