|
|
马上注册，结识高手，享用更多资源，轻松玩转三维网社区。
您需要 登录 才可以下载或查看，没有帐号？注册
x
使用方法：“Alt+F11”打开“VBA编辑器”，单击“工具”菜单，单击“引用”，在弹出的“引用－ACADObject”对话框中寻找并选中Microsoft Excel类型库(比如本机安装的Excel是2000版，引用的类型库就是“Microsoft Excel 9.0 Object Library”)。“确定”后退出对话框。双击“工程资源管理器”中的“ThisDrawing”对象，在弹出的代码窗口粘贴下面代码，“F5”运行。
" ?- J9 ^6 Z8 G5 n
/ ^# T4 x6 P5 G8 e" v''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''1 ` s, ?- `! ^1 `+ W8 G8 p- L
Sub TC(): ?6 F, [% ]* c& Y$ G
Dim R As Integer, C As Integer, I As Integer, Ly As AcadLayer" |7 F$ ^1 ?* l* s% Y5 R, u
Dim xlApp As Excel.Application, xlBook As Excel.Workbook# A2 U; F. m U8 l- g, x
2 S$ o" |5 Z# x R = 1: C = 1 '从工作表的第1行第1列开始填写，使用者自行更改
) x" j1 G2 z# S* x5 \/ K# q1 V7 ^
* n/ ] b2 K2 t! K& g2 \6 J Set xlApp = CreateObject("Excel.Application") '打开EXCEL程序# [8 Z" w w5 x
xlApp.Visible = True '使EXCEL程序可见 T9 R; [& U) j, _; v9 P
Set xlBook = xlApp.Workbooks.Add '插入新工作薄2 O$ f) s: Z2 S: u* x' _
With xlBook.ActiveSheet
7 d* q. S$ h, ^. a+ B .Name = "图层信息" '重命名当前工作表
8 t( t2 p; x2 W I = R
, H U# m$ a) I; [' Q' |4 X .Range(.Cells(I, C), .Cells(I, C + 11)).HorizontalAlignment = xlCenter '所有填写项目名称的单元格水平中心对齐
7 a* [% o6 l" W. I+ g: k- g- X .Cells(I, C).Value = "序号" '以下代码逐列填写项目名称" X! o) \& [' g$ h' T
.Cells(I, C + 1).Value = "状态"
+ q: }' r$ S, e! H9 W5 h! g- o, d .Cells(I, C + 2).Value = "名称"
' J. j; X* q+ O6 e! ^ .Cells(I, C + 3).Value = "开关"
1 H; ~- r; q5 G. x- h% {! `. x .Cells(I, C + 4).Value = "冻结"
8 u, ^. g+ W; [4 E .Cells(I, C + 5).Value = "锁定"
% x( L8 j& J6 q: m' X4 t% B+ K .Cells(I, C + 6).Value = "颜色"
" C% w E8 f3 r* g4 N .Cells(I, C + 7).Value = "线型"
" `& D* R4 d& T" e/ Q* f .Cells(I, C + 8).Value = "线宽"( \. J/ s3 W! j# P7 o
.Cells(I, C + 9).Value = "打印样式"
q( X# B; T+ l* l2 B1 n .Cells(I, C + 10).Value = "打印": n7 F2 `4 J. Y% a" j
.Cells(I, C + 11).Value = "说明"4 c: z7 v$ k4 e
For Each Ly In ThisDrawing.Layers '遍历图层7 U( D7 q2 t4 p6 d
I = I + 1 '在下一行填写该图层信息
# l' J" C- e7 ?# q' r! U) i .Range(.Cells(I, C), .Cells(I, C + 10)).HorizontalAlignment = xlCenter '前11项信息所在单元格水平中心对齐 P" n, }+ q: Z7 O4 L+ c6 r
.Cells(I, C + 11).HorizontalAlignment = xlLeft '填写图层说明的单元格水平左对齐
2 C' [: R: x5 S0 H* l/ I .Cells(I, C).Value = I - 1 '在第1列填写序号3 K! R# f, y6 \
If Ly.Used Then .Cells(I, C + 1).Value = "已使用" Else .Cells(I, C + 1).Value = "未使用" '第2列填写使用状态 ` C( }% o& I% k/ H4 c+ u$ i
.Cells(I, C + 2).Value = Ly.Name '第3列填写图层名称9 D2 o* {7 O' O6 |
If Ly.LayerOn Then .Cells(I, C + 3).Value = "开" Else .Cells(I, C + 3).Value = "关" '第4列填写开关状态
4 L9 Y' R8 M& s9 @' R8 V& [ If Ly.Freeze Then .Cells(I, C + 4).Value = "已冻结" Else .Cells(I, C + 4).Value = "未冻结" '第5列填写冻结状态9 v8 a9 L8 D; l6 V/ K' x
If Ly.Lock Then .Cells(I, C + 5).Value = "已锁定" Else .Cells(I, C + 5).Value = "未锁定" '第6列填写锁定状态( j0 o( S) p) v w
Select Case Ly.TrueColor.ColorMethod '检查颜色定义的方法
* T: Q3 r9 L7 j# l7 A9 P8 ]; B! m U Case 194 '该图层颜色定义为RGB颜色时，在第7列填写RGB颜色8 I& [0 k" o9 F; a8 x [- L. D% S
.Cells(I, C + 6).Value = "RGB颜色" & Ly.TrueColor.Red & "," & Ly.TrueColor.Green & "," & Ly.TrueColor.Blue$ _; w8 y( w0 z+ W; c J, C
Case 195 '该图层颜色定义为索引颜色时
, p# Z6 ^8 K! T% Y. Y3 s* r Select Case Ly.TrueColor.ColorIndex
" W! v q5 s0 \6 p5 c; o" Y2 _ Case 1 '以下代码按索引号在第7列填写颜色名称5 I# l i& ?0 @; m8 I" m
.Cells(I, C + 6).Value = "红"5 Z& B0 C* a& `4 O# _. ^5 G9 G/ v) W+ w
Case 24 |2 j+ w7 m- \: ^3 G, p
.Cells(I, C + 6).Value = "黄"
4 P' i ^: k6 v1 }$ C \4 H( H! | Case 32 M3 s+ x/ e5 a$ U0 X. H
.Cells(I, C + 6).Value = "绿"
4 G' f# @# q2 {8 B! _8 j Case 4
2 q& n. E9 x8 B! m .Cells(I, C + 6).Value = "青"1 q' c$ \+ ?, D- x( n. s/ H; w
Case 5- ^$ l$ S0 T0 c( T& H1 q
.Cells(I, C + 6).Value = "蓝"( ]: v# o5 X' y( n0 k: f% g! X
Case 6
# F4 ?* c$ Z( u+ d .Cells(I, C + 6).Value = "洋红"
" e/ o* I, f4 w: t! S Case 70 Y) `. j) X9 m
.Cells(I, C + 6).Value = "白"
) |; e: V$ K9 }1 ?2 W' }( f O3 | Case Else '无名称的索引颜色在第7列填写索引号$ G) Q M+ J$ K; d& ^
.Cells(I, C + 6).Value = "索引颜色" & Ly.TrueColor.ColorIndex
6 q7 o. e, }; u: w. I End Select1 R2 T+ W7 c7 n5 R0 F7 E, D
End Select! u. y; l5 Z1 A6 I6 |7 O# r
.Cells(I, C + 7).Value = Ly.Linetype '第8列填写线型名称
2 F. d; n& o- s' Y) V9 s Select Case Ly.Lineweight '第9列填写线宽
: t4 N" r- Y5 K% T& j t n Case -3 '2 s& t8 u2 m5 u$ _1 ^, x
.Cells(I, C + 8).Value = "默认"- v9 L8 y2 j2 o* Y
Case Else
, R; L1 |% y, Q& B n .Cells(I, C + 8).Value = Val(Ly.Lineweight) / 100
" E7 d8 q% ]7 F( G3 H% t+ D$ o& p End Select" z$ z+ ?: L; f* I6 A
.Cells(I, C + 9).Value = Ly.PlotStyleName '第10列填写打印样式名称
. C' O1 t8 M L9 p) Z+ ~( `9 Z If Ly.Plottable Then .Cells(I, C + 10).Value = "打印" Else .Cells(I, C + 10).Value = "不打印" '第11列填写是否打印8 b- f0 _( ~6 h' R; z
.Cells(I, C + 11).Value = Ly.Description '第12列填写图层说明% @5 l! c7 o/ N! H- B% m! M! H2 L
Next
8 [' Y; A1 b) M1 h .Range(.Cells(R, C), .Cells(I, C + 11)).Columns.AutoFit '最适合的列宽
* A! O3 q+ b7 k End With0 W0 N3 y6 W& K u' b* I; y
End Sub
% S( @ h4 U! q& r4 Q'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''* ]6 W1 N8 \( R, L3 p/ k$ z
6 l- Y r$ F* I运行结果
% b9 B, Q, G9 ]
|
评分
-
查看全部评分
|
发表于 2008-6-17 11:38:22
发表于 2009-2-26 14:47:11