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

woaishuijia

使用方法：“Alt+F11”打开“VBA编辑器”，单击“工具”菜单，单击“引用”，在弹出的“引用－ACADObject”对话框中寻找并选中Microsoft Excel类型库(比如本机安装的Excel是2000版，引用的类型库就是“Microsoft Excel 9.0 Object Library”)。“确定”后退出对话框。双击“工程资源管理器”中的“ThisDrawing”对象，在弹出的代码窗口粘贴下面代码，“F5”运行。
' s/ ]4 |! P8 D/ Y4 ^0 P" d: h5 q+ ^
6 W" |/ b! H0 {+ X) z''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
6 m- l3 y2 r; S+ s# u5 g! [+ uSub TC()
    Dim R As Integer, C As Integer, I As Integer, Ly As AcadLayer
    Dim xlApp As Excel.Application, xlBook As Excel.Workbook
! j% z+ D: [7 s8 t: I+ Q   
  K) o! |1 [8 Z. r7 A% \( ?    R = 1: C = 1 '从工作表的第1行第1列开始填写，使用者自行更改
   
' B: F* e9 E* ]) g# g    Set xlApp = CreateObject("Excel.Application") '打开EXCEL程序
6 A: J' \7 _; L( d& I    xlApp.Visible = True '使EXCEL程序可见
4 @# Y$ F; r. j# P: W& Q, N    Set xlBook = xlApp.Workbooks.Add '插入新工作薄
: ^" R/ _, [9 Q$ N    With xlBook.ActiveSheet
$ Q7 U1 M) b/ J0 L1 T        .Name = "图层信息" '重命名当前工作表
: c7 n: w8 q$ M: K0 m. y        I = R
& u* Y7 G' z; M5 }        .Range(.Cells(I, C), .Cells(I, C + 11)).HorizontalAlignment = xlCenter  '所有填写项目名称的单元格水平中心对齐
        .Cells(I, C).Value = "序号"  '以下代码逐列填写项目名称
- F1 ^& |# k& X$ Z: ~        .Cells(I, C + 1).Value = "状态"
# M% |6 Q+ r3 z. _9 D8 f- q5 C        .Cells(I, C + 2).Value = "名称"
) }4 ]& T8 r; j" q2 g2 I8 t        .Cells(I, C + 3).Value = "开关"
5 k& K/ \" b5 ]  D: `) E        .Cells(I, C + 4).Value = "冻结"
        .Cells(I, C + 5).Value = "锁定"
& E  D% d7 Y  z" Q3 y+ d- X+ \        .Cells(I, C + 6).Value = "颜色"
' a( z7 I5 K5 N) B4 C        .Cells(I, C + 7).Value = "线型"
8 G0 G+ o' E+ ?3 [* t' j# B        .Cells(I, C + 8).Value = "线宽"
4 c. {. l+ Q5 o3 t5 \        .Cells(I, C + 9).Value = "打印样式"
        .Cells(I, C + 10).Value = "打印"
' A- B2 a: x$ w- d+ i        .Cells(I, C + 11).Value = "说明"
        For Each Ly In ThisDrawing.Layers '遍历图层
% S- ]/ m* _4 h" }            I = I + 1 '在下一行填写该图层信息
            .Range(.Cells(I, C), .Cells(I, C + 10)).HorizontalAlignment = xlCenter  '前11项信息所在单元格水平中心对齐
/ s9 q- g2 h, ^/ `# ?9 Q            .Cells(I, C + 11).HorizontalAlignment = xlLeft '填写图层说明的单元格水平左对齐
            .Cells(I, C).Value = I - 1  '在第1列填写序号
            If Ly.Used Then .Cells(I, C + 1).Value = "已使用" Else .Cells(I, C + 1).Value = "未使用" '第2列填写使用状态
. m' w5 Z# X6 W1 f4 [# @            .Cells(I, C + 2).Value = Ly.Name '第3列填写图层名称
  q7 f6 p; K3 i# |# u            If Ly.LayerOn Then .Cells(I, C + 3).Value = "开" Else .Cells(I, C + 3).Value = "关" '第4列填写开关状态
& H, X( n$ U' k$ O- u            If Ly.Freeze Then .Cells(I, C + 4).Value = "已冻结" Else .Cells(I, C + 4).Value = "未冻结" '第5列填写冻结状态
- m' I6 l( x: N! C            If Ly.Lock Then .Cells(I, C + 5).Value = "已锁定" Else .Cells(I, C + 5).Value = "未锁定" '第6列填写锁定状态
            Select Case Ly.TrueColor.ColorMethod '检查颜色定义的方法
, z6 e3 k+ T3 ^0 N1 ]6 T; ?                Case 194 '该图层颜色定义为RGB颜色时，在第7列填写RGB颜色
                    .Cells(I, C + 6).Value = "RGB颜色" & Ly.TrueColor.Red & "," & Ly.TrueColor.Green & "," & Ly.TrueColor.Blue
  h! ~- C/ w& `; d  x                Case 195 '该图层颜色定义为索引颜色时
                    Select Case Ly.TrueColor.ColorIndex
9 H9 c$ K. J0 Q. j& m                        Case 1 '以下代码按索引号在第7列填写颜色名称
                            .Cells(I, C + 6).Value = "红"
                        Case 2
# t( t% ?  I+ {$ {# n& L& X                            .Cells(I, C + 6).Value = "黄"
5 o! g1 t, `- P* l+ O6 B3 B/ J1 ?                        Case 3
                            .Cells(I, C + 6).Value = "绿"
                        Case 4
                            .Cells(I, C + 6).Value = "青"
                        Case 5
                            .Cells(I, C + 6).Value = "蓝"
8 m8 k( B' q: n% b                        Case 6
                            .Cells(I, C + 6).Value = "洋红"
                        Case 7
: \. R4 s) t3 h5 F5 \  [                            .Cells(I, C + 6).Value = "白"
) o+ N8 v$ q6 @# ^                        Case Else '无名称的索引颜色在第7列填写索引号
1 U# k. [# d$ w9 P# S                            .Cells(I, C + 6).Value = "索引颜色" & Ly.TrueColor.ColorIndex
4 U% K/ |* i4 a, l) P1 ^0 t                    End Select
            End Select
            .Cells(I, C + 7).Value = Ly.Linetype '第8列填写线型名称
            Select Case Ly.Lineweight '第9列填写线宽
6 m. f3 T5 D$ U& `. ?5 v/ L- j                Case -3 '
# f! J9 c1 q) Y. L# z                    .Cells(I, C + 8).Value = "默认"
* N3 k4 Y1 e- f( J, k' I                Case Else
" U  j, p1 E7 B  U! C% W$ P  V                    .Cells(I, C + 8).Value = Val(Ly.Lineweight) / 100
            End Select
( s2 g- I( R% w, h            .Cells(I, C + 9).Value = Ly.PlotStyleName '第10列填写打印样式名称
3 l( M& u6 N0 r' D0 p+ 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列填写图层说明
        Next
' ~( Z4 o( n0 i9 S6 i) j        .Range(.Cells(R, C), .Cells(I, C + 11)).Columns.AutoFit '最适合的列宽
. h: Z1 v# m8 A$ O" a    End With
End Sub
' V6 g. n. o( S'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

' d% B# ~9 m: w/ G- A运行结果

sailinggirl

感谢，楼主辛苦了

great829

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

64400732

谢谢楼主，参考了，厉害

kinatec

感谢楼主分享! Ding

spidow

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

u47321111

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

baby008

不错不错  厉害