|
|
马上注册，结识高手，享用更多资源，轻松玩转三维网社区。
您需要 登录 才可以下载或查看，没有帐号？注册
x
使用方法：“Alt+F11”打开“VBA编辑器”，单击“工具”菜单，单击“引用”，在弹出的“引用－ACADObject”对话框中寻找并选中Microsoft Excel类型库(比如本机安装的Excel是2000版，引用的类型库就是“Microsoft Excel 9.0 Object Library”)。“确定”后退出对话框。双击“工程资源管理器”中的“ThisDrawing”对象，在弹出的代码窗口粘贴下面代码，“F5”运行。' h- v8 T, V8 x9 _. I
2 ?' M# I, f. n! k1 [3 h
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
/ ?0 ~4 N) J: _8 h9 _Sub TC() i( Z, S7 ^# c; E! g: f/ `0 ^! A
Dim R As Integer, C As Integer, I As Integer, Ly As AcadLayer, U- k& Q1 g7 d+ [
Dim xlApp As Excel.Application, xlBook As Excel.Workbook. ~, ]' u8 T3 q9 \6 b4 Y
3 t, |0 a- G+ s3 O* ? R = 1: C = 1 '从工作表的第1行第1列开始填写，使用者自行更改
7 U5 s( t4 K2 r/ I1 r* y! W2 R' f 3 u& w7 m4 C6 g4 V7 e5 g5 \
Set xlApp = CreateObject("Excel.Application") '打开EXCEL程序& Q$ o. l- ~/ D! Q" a9 R
xlApp.Visible = True '使EXCEL程序可见6 Z( l$ {4 E( d
Set xlBook = xlApp.Workbooks.Add '插入新工作薄
' V5 N/ k3 y& \6 r$ Q0 C With xlBook.ActiveSheet2 _* Q! {2 S) C$ z3 y
.Name = "图层信息" '重命名当前工作表6 Q' G) Y+ `* m' N2 _% ]* d
I = R
3 R* c& Z% {1 f' [2 p) u' N4 [& g6 ? .Range(.Cells(I, C), .Cells(I, C + 11)).HorizontalAlignment = xlCenter '所有填写项目名称的单元格水平中心对齐
7 H2 I* v, I$ o) j# ~2 m# x .Cells(I, C).Value = "序号" '以下代码逐列填写项目名称% u% V2 E% T) `3 o! e
.Cells(I, C + 1).Value = "状态"
8 o3 |# U3 Y. C1 B' ^# F- F' x: \ .Cells(I, C + 2).Value = "名称"
: v2 _6 h) l/ j- Z1 e4 A; Y .Cells(I, C + 3).Value = "开关"
( Z1 a, ]# y* a/ C# A .Cells(I, C + 4).Value = "冻结"
" Z. f* M; T1 C! e .Cells(I, C + 5).Value = "锁定"
, y3 D+ K! X: w .Cells(I, C + 6).Value = "颜色"
* {& a3 }0 B6 c" R& o. H8 @% R( Y .Cells(I, C + 7).Value = "线型" g9 M. i" Q# W
.Cells(I, C + 8).Value = "线宽"2 s; \/ q/ J8 q& Z
.Cells(I, C + 9).Value = "打印样式"3 {9 ] X: \2 I( M
.Cells(I, C + 10).Value = "打印"
2 e+ c+ f- y9 x .Cells(I, C + 11).Value = "说明"* x3 K- Q& F" Q2 |" r
For Each Ly In ThisDrawing.Layers '遍历图层6 g0 S4 Q: q6 h0 C. ^' q; l( j
I = I + 1 '在下一行填写该图层信息
( x3 G. |! I. p" M0 I .Range(.Cells(I, C), .Cells(I, C + 10)).HorizontalAlignment = xlCenter '前11项信息所在单元格水平中心对齐% w& X) m1 P2 V" m
.Cells(I, C + 11).HorizontalAlignment = xlLeft '填写图层说明的单元格水平左对齐5 X7 [4 C* \) {
.Cells(I, C).Value = I - 1 '在第1列填写序号3 u: i1 { \$ X, |
If Ly.Used Then .Cells(I, C + 1).Value = "已使用" Else .Cells(I, C + 1).Value = "未使用" '第2列填写使用状态 Q1 T; D' ^# ]; K& Z& Y% w
.Cells(I, C + 2).Value = Ly.Name '第3列填写图层名称, n$ V5 j& }& e5 I/ Y' q7 \
If Ly.LayerOn Then .Cells(I, C + 3).Value = "开" Else .Cells(I, C + 3).Value = "关" '第4列填写开关状态
: t [! W$ D& e6 h If Ly.Freeze Then .Cells(I, C + 4).Value = "已冻结" Else .Cells(I, C + 4).Value = "未冻结" '第5列填写冻结状态( P2 y% l3 j' A" h8 }
If Ly.Lock Then .Cells(I, C + 5).Value = "已锁定" Else .Cells(I, C + 5).Value = "未锁定" '第6列填写锁定状态
2 o3 t8 p# \$ v! _4 {0 K Select Case Ly.TrueColor.ColorMethod '检查颜色定义的方法
! S' y( ~: w& j T( ] Case 194 '该图层颜色定义为RGB颜色时，在第7列填写RGB颜色7 Z p3 s/ m: C* G7 K G
.Cells(I, C + 6).Value = "RGB颜色" & Ly.TrueColor.Red & "," & Ly.TrueColor.Green & "," & Ly.TrueColor.Blue u& }1 ?7 n, ~- Z. R L% o4 M/ V
Case 195 '该图层颜色定义为索引颜色时6 C% u. d e; o, K! C* ^, `" J+ n
Select Case Ly.TrueColor.ColorIndex$ Y* A, h$ ?$ A. [4 ^3 e# n8 j2 S- O
Case 1 '以下代码按索引号在第7列填写颜色名称4 r m5 f; S& S% S' r4 g5 _; S
.Cells(I, C + 6).Value = "红"
) d. A8 V9 A9 f- p Case 22 M3 _& m# Z. Z' c; J% u
.Cells(I, C + 6).Value = "黄"
5 \" w8 D: z- Z" N Case 36 R0 u0 o2 _5 `6 |" f
.Cells(I, C + 6).Value = "绿"
+ u8 M# _5 _4 U" D Case 4
5 }* E! q: q' i1 @% V .Cells(I, C + 6).Value = "青"( R- \# J' H+ n) b% O; D {4 M
Case 5
; e/ m: m7 |6 @ ] p8 s .Cells(I, C + 6).Value = "蓝"* v- T) h! ]+ R: F
Case 6
; V( H- c* C0 b+ K! ^- \5 g1 a .Cells(I, C + 6).Value = "洋红"/ S/ P n7 K9 `
Case 7
) u! W" ` \$ P5 [, W W .Cells(I, C + 6).Value = "白"( n' h5 |' [# @+ E3 |" r* N
Case Else '无名称的索引颜色在第7列填写索引号
0 ^9 e: S& ^# r$ i+ r, y! _ .Cells(I, C + 6).Value = "索引颜色" & Ly.TrueColor.ColorIndex
1 G; x0 y2 A4 i. u" K9 y: {% } End Select
$ e- B- X7 _# a2 ~+ q* u7 F' L End Select
, l+ j( [6 N T$ v# X s0 Y .Cells(I, C + 7).Value = Ly.Linetype '第8列填写线型名称
( X9 L* z* v5 ~* {$ g$ Q! h; | Select Case Ly.Lineweight '第9列填写线宽: k1 p+ s* k/ }( V, d
Case -3 '
( n* s9 x0 S+ e3 | R+ x .Cells(I, C + 8).Value = "默认"
: r4 A# h; f# x9 D Case Else
, e o/ x2 @& u$ ~ .Cells(I, C + 8).Value = Val(Ly.Lineweight) / 100
3 }( D% f4 o) N& D4 A$ h End Select2 r& I2 W* G4 h6 I- k! [
.Cells(I, C + 9).Value = Ly.PlotStyleName '第10列填写打印样式名称
" ?3 h" ^: g' I6 K If Ly.Plottable Then .Cells(I, C + 10).Value = "打印" Else .Cells(I, C + 10).Value = "不打印" '第11列填写是否打印
( s$ ~4 k- B4 B' X) N: | .Cells(I, C + 11).Value = Ly.Description '第12列填写图层说明: }- G' e/ j* r, V
Next9 f+ L0 g6 ^+ H: h* @ v. n
.Range(.Cells(R, C), .Cells(I, C + 11)).Columns.AutoFit '最适合的列宽
0 G) o4 E9 @; V$ B6 [# | End With
+ q' Q# R; m! |4 B) xEnd Sub
" l8 `4 v0 B) R''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' T) V# s6 D/ g+ x- v v# U' Y
/ T1 m: D3 E. D; n" a/ o% {- |运行结果
$ p/ Q! e1 F% b" h! ?7 k5 z
|
评分
-
查看全部评分
|
发表于 2008-6-17 11:38:22
发表于 2009-2-26 14:47:11