|
|
马上注册，结识高手，享用更多资源，轻松玩转三维网社区。
您需要 登录 才可以下载或查看，没有帐号？注册
x
使用方法：“Alt+F11”打开“VBA编辑器”，单击“工具”菜单，单击“引用”，在弹出的“引用－ACADObject”对话框中寻找并选中Microsoft Excel类型库(比如本机安装的Excel是2000版，引用的类型库就是“Microsoft Excel 9.0 Object Library”)。“确定”后退出对话框。双击“工程资源管理器”中的“ThisDrawing”对象，在弹出的代码窗口粘贴下面代码，“F5”运行。7 ], {( h, V- i. ]5 h4 ~- q' }
6 ~4 V: p3 s0 J
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
: _* e: b/ w4 ~. F& M' a" ^0 vSub TC()
g: A$ j5 Q& m0 h. }; Q Dim R As Integer, C As Integer, I As Integer, Ly As AcadLayer% @; r* P) u: d' h0 Z
Dim xlApp As Excel.Application, xlBook As Excel.Workbook
3 \4 E& b+ w9 k/ A# }* d9 S* W+ c
2 K2 E# n( h7 t. j R = 1: C = 1 '从工作表的第1行第1列开始填写，使用者自行更改0 a' X ^/ A6 V* Q
+ b3 U2 L7 i6 q* }( I7 q Set xlApp = CreateObject("Excel.Application") '打开EXCEL程序2 N) [3 T P$ |# y. X
xlApp.Visible = True '使EXCEL程序可见
% H5 u4 K: N/ W$ m+ x( s# {- C; P2 O Set xlBook = xlApp.Workbooks.Add '插入新工作薄' H% }4 }8 K# e( e8 ~6 W9 O0 @9 K
With xlBook.ActiveSheet% t) i: \: \! ?7 _* p& g# c% U
.Name = "图层信息" '重命名当前工作表* C/ k9 F$ ~0 Q" ~
I = R2 {% u; \# Y Y# D6 I
.Range(.Cells(I, C), .Cells(I, C + 11)).HorizontalAlignment = xlCenter '所有填写项目名称的单元格水平中心对齐
0 f7 {( n% \8 y. M; h .Cells(I, C).Value = "序号" '以下代码逐列填写项目名称& _+ o4 `7 g$ f0 P
.Cells(I, C + 1).Value = "状态"
1 `' b- K4 j$ @9 M3 a! e% V* Q .Cells(I, C + 2).Value = "名称"( o1 \$ o/ ^/ q2 v( j$ \
.Cells(I, C + 3).Value = "开关"+ Y" @+ M( r1 Z- T9 g
.Cells(I, C + 4).Value = "冻结"
9 k3 K7 b1 ] F$ A O6 T .Cells(I, C + 5).Value = "锁定"
1 R5 C$ k L- f9 ^( ]. a .Cells(I, C + 6).Value = "颜色"
& |: s- Y( T8 i8 v4 m- o .Cells(I, C + 7).Value = "线型"
3 a2 G, G0 q6 p5 Y/ W8 {8 b$ e .Cells(I, C + 8).Value = "线宽"7 K1 z% Y& L* s% Z: Y! f! E' q
.Cells(I, C + 9).Value = "打印样式"/ \; i$ g' G. W8 a: I3 q
.Cells(I, C + 10).Value = "打印"& T( w" U8 W2 L6 m+ {" O1 \
.Cells(I, C + 11).Value = "说明"1 Q0 Q( W- V0 J0 b9 B
For Each Ly In ThisDrawing.Layers '遍历图层2 \ p$ u, O, N$ f
I = I + 1 '在下一行填写该图层信息
. X8 `: ?1 M$ ?2 E ^ .Range(.Cells(I, C), .Cells(I, C + 10)).HorizontalAlignment = xlCenter '前11项信息所在单元格水平中心对齐
$ [) P1 P! g- I .Cells(I, C + 11).HorizontalAlignment = xlLeft '填写图层说明的单元格水平左对齐
( x @# Z# P7 C0 R3 e .Cells(I, C).Value = I - 1 '在第1列填写序号$ h4 v1 N5 P% ~
If Ly.Used Then .Cells(I, C + 1).Value = "已使用" Else .Cells(I, C + 1).Value = "未使用" '第2列填写使用状态
* V- y+ |" H7 v .Cells(I, C + 2).Value = Ly.Name '第3列填写图层名称
" m9 m/ C3 w2 }' Y, v: S6 T If Ly.LayerOn Then .Cells(I, C + 3).Value = "开" Else .Cells(I, C + 3).Value = "关" '第4列填写开关状态
4 \6 B: W6 e R j L$ b If Ly.Freeze Then .Cells(I, C + 4).Value = "已冻结" Else .Cells(I, C + 4).Value = "未冻结" '第5列填写冻结状态
+ E# N9 u& U3 H9 I1 C) n# O If Ly.Lock Then .Cells(I, C + 5).Value = "已锁定" Else .Cells(I, C + 5).Value = "未锁定" '第6列填写锁定状态0 b- V2 H/ h* S4 Q. z" F
Select Case Ly.TrueColor.ColorMethod '检查颜色定义的方法
, P% u8 W( T8 A( [! V% y& F% f" p Case 194 '该图层颜色定义为RGB颜色时，在第7列填写RGB颜色" V2 ~8 S) @# t' U* Z# k
.Cells(I, C + 6).Value = "RGB颜色" & Ly.TrueColor.Red & "," & Ly.TrueColor.Green & "," & Ly.TrueColor.Blue! I+ c R" U8 S$ Y0 `9 a* F2 ?
Case 195 '该图层颜色定义为索引颜色时
3 Q1 U+ i# I# D8 X g- }; M Select Case Ly.TrueColor.ColorIndex% ]) E, X# V/ s6 r. Z
Case 1 '以下代码按索引号在第7列填写颜色名称! i2 b7 i8 @! D- k6 T( s. t
.Cells(I, C + 6).Value = "红"
3 j+ s, o9 y) B! \% m" y' W Case 2
o; M8 o$ L( ^4 _, h .Cells(I, C + 6).Value = "黄"
7 f( y+ Z7 j- t$ ~5 ? Case 3
: q7 p$ F5 i2 \( ~8 L .Cells(I, C + 6).Value = "绿"7 }2 w; ~ B/ {. G
Case 4
: x6 I5 }; f0 X. L( d# o .Cells(I, C + 6).Value = "青"" r2 U1 j4 R5 N8 j+ P
Case 5
+ O; E* {4 }$ T5 r5 ]/ X: ] .Cells(I, C + 6).Value = "蓝"2 D3 X" g% w. W0 G2 \/ X
Case 6% i0 |4 }5 ^, T' x! |: U* `3 e
.Cells(I, C + 6).Value = "洋红"
1 W7 K/ o& @* }/ R6 w Case 7
2 w: w. w3 x+ x' f+ L1 |- ^/ ?0 K& b8 o' I1 t .Cells(I, C + 6).Value = "白"( R, W* q0 G, T& V& A' k
Case Else '无名称的索引颜色在第7列填写索引号7 n3 {8 g( M' n M1 n
.Cells(I, C + 6).Value = "索引颜色" & Ly.TrueColor.ColorIndex: C- ~( m! V/ s' a+ k1 U
End Select0 z* U6 S! N" t) s: Q* z* n# @
End Select
0 p- q/ Q: D1 n .Cells(I, C + 7).Value = Ly.Linetype '第8列填写线型名称# u, O) }/ W8 I/ r( b+ _
Select Case Ly.Lineweight '第9列填写线宽
5 C' I. F% ]& F: A; r Case -3 '
2 Q Y2 @/ `5 v5 C .Cells(I, C + 8).Value = "默认"+ l1 `. W: Y* u2 g7 e6 X
Case Else
5 y6 f# r4 Z+ q .Cells(I, C + 8).Value = Val(Ly.Lineweight) / 100
0 C3 y: _4 h9 w8 \ End Select
, h" ?9 W# p" @4 M/ e" Z( i .Cells(I, C + 9).Value = Ly.PlotStyleName '第10列填写打印样式名称- R# g- C+ p2 H& i2 p5 X+ B
If Ly.Plottable Then .Cells(I, C + 10).Value = "打印" Else .Cells(I, C + 10).Value = "不打印" '第11列填写是否打印
) s1 `% L, D3 z# M9 f" @ .Cells(I, C + 11).Value = Ly.Description '第12列填写图层说明
L2 S" _: n6 h Next9 X: f4 f' U9 Y' q$ ]4 [4 s" E" U
.Range(.Cells(R, C), .Cells(I, C + 11)).Columns.AutoFit '最适合的列宽
' ?) ^; b7 ~) c. P End With$ d5 h3 g7 }9 j! d% l
End Sub
# T2 B" ?* h8 n7 {2 ?'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' P4 H- Y' g$ {9 f o3 X& f
' b& Q) f8 u' W: |" k/ K) {- U
运行结果
( D! a) g3 H7 [, B- p0 `
|
评分
-
查看全部评分
|
发表于 2008-6-17 11:38:22
发表于 2009-2-26 14:47:11