|
|
马上注册，结识高手，享用更多资源，轻松玩转三维网社区。
您需要 登录 才可以下载或查看，没有帐号？注册
x
使用方法：“Alt+F11”打开“VBA编辑器”，单击“工具”菜单，单击“引用”，在弹出的“引用－ACADObject”对话框中寻找并选中Microsoft Excel类型库(比如本机安装的Excel是2000版，引用的类型库就是“Microsoft Excel 9.0 Object Library”)。“确定”后退出对话框。双击“工程资源管理器”中的“ThisDrawing”对象，在弹出的代码窗口粘贴下面代码，“F5”运行。7 N3 h+ G) W2 H0 U. K ^ B% \
7 W9 E+ u7 v+ i# R8 f
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
7 l* U/ G: I* [. M( @Sub TC(): A, d% \" T/ Y9 L" E2 z3 t
Dim R As Integer, C As Integer, I As Integer, Ly As AcadLayer: w3 l3 O0 X/ C
Dim xlApp As Excel.Application, xlBook As Excel.Workbook
6 t: G" Y7 ]# \6 c ; O% z' Q# q$ t+ B* O8 [+ d% V8 H/ c
R = 1: C = 1 '从工作表的第1行第1列开始填写，使用者自行更改
6 E V. e2 q$ P h
% s& Z. o' y5 x Set xlApp = CreateObject("Excel.Application") '打开EXCEL程序
9 S4 j' `7 H! @) E+ A- N9 p0 A xlApp.Visible = True '使EXCEL程序可见
' m# h6 K) T: H% F Set xlBook = xlApp.Workbooks.Add '插入新工作薄
: u1 N$ |1 }4 m- P With xlBook.ActiveSheet+ Z, l" q, a; ~1 E
.Name = "图层信息" '重命名当前工作表& h. d9 i5 m! o- k. ?
I = R4 U4 v$ F4 h# S5 x& h% B- G/ X. A
.Range(.Cells(I, C), .Cells(I, C + 11)).HorizontalAlignment = xlCenter '所有填写项目名称的单元格水平中心对齐
6 ~; v. k3 } l0 D4 d% M/ f) f; E .Cells(I, C).Value = "序号" '以下代码逐列填写项目名称4 t2 j( `2 q/ e. K7 H: y! I
.Cells(I, C + 1).Value = "状态"
& p9 ]" H1 E0 | M+ i .Cells(I, C + 2).Value = "名称"
' K$ h5 D" s- ?. M" M# X; z0 u .Cells(I, C + 3).Value = "开关"/ c. o# u" \" g1 Y4 v/ N
.Cells(I, C + 4).Value = "冻结"$ F, f6 `: R8 F( R4 F
.Cells(I, C + 5).Value = "锁定"
6 M' r6 \0 l( [! f: B5 p .Cells(I, C + 6).Value = "颜色"
: k" O8 ^ o) F6 e3 F .Cells(I, C + 7).Value = "线型", J' {) g' m% Y+ X* e$ U
.Cells(I, C + 8).Value = "线宽"
8 y1 K) ~) A* J1 x- Z" m. A .Cells(I, C + 9).Value = "打印样式") Z5 y/ I6 m) T9 L4 B
.Cells(I, C + 10).Value = "打印"* e5 f; _) A. ], ?- x
.Cells(I, C + 11).Value = "说明"
6 j6 Z! n5 l* j6 d% }1 D6 q2 p& X0 L For Each Ly In ThisDrawing.Layers '遍历图层7 O' c# B6 S& R5 f5 }
I = I + 1 '在下一行填写该图层信息
$ B! n1 U; T% Z M8 X) a .Range(.Cells(I, C), .Cells(I, C + 10)).HorizontalAlignment = xlCenter '前11项信息所在单元格水平中心对齐* C* }6 E- C8 _; z% p \
.Cells(I, C + 11).HorizontalAlignment = xlLeft '填写图层说明的单元格水平左对齐% j6 `4 u4 d; d8 i
.Cells(I, C).Value = I - 1 '在第1列填写序号
4 ]+ m- a9 A8 b& _/ R If Ly.Used Then .Cells(I, C + 1).Value = "已使用" Else .Cells(I, C + 1).Value = "未使用" '第2列填写使用状态' l: u& {& w X! b* w" U8 O
.Cells(I, C + 2).Value = Ly.Name '第3列填写图层名称
% E; J8 c" k9 t D' U If Ly.LayerOn Then .Cells(I, C + 3).Value = "开" Else .Cells(I, C + 3).Value = "关" '第4列填写开关状态' _* R8 h t9 i5 g; h1 g8 [
If Ly.Freeze Then .Cells(I, C + 4).Value = "已冻结" Else .Cells(I, C + 4).Value = "未冻结" '第5列填写冻结状态9 g7 C" i6 K& ^/ Q5 \2 E3 j W+ T
If Ly.Lock Then .Cells(I, C + 5).Value = "已锁定" Else .Cells(I, C + 5).Value = "未锁定" '第6列填写锁定状态- Q3 I! b- d1 Q- w
Select Case Ly.TrueColor.ColorMethod '检查颜色定义的方法
Q8 w8 ~+ R+ w& d! h Case 194 '该图层颜色定义为RGB颜色时，在第7列填写RGB颜色6 Q$ q) `3 v1 @0 X
.Cells(I, C + 6).Value = "RGB颜色" & Ly.TrueColor.Red & "," & Ly.TrueColor.Green & "," & Ly.TrueColor.Blue. a& b9 K* Z' Q3 N9 i$ @2 k$ F& B
Case 195 '该图层颜色定义为索引颜色时
U4 D$ g( O4 h( N Select Case Ly.TrueColor.ColorIndex
0 q9 ]+ {. s2 d( `+ y Case 1 '以下代码按索引号在第7列填写颜色名称
5 D) t; `+ ~/ o P7 b8 z .Cells(I, C + 6).Value = "红"
. s6 u0 J3 Z. g# I Case 2% k; e# S& o: O$ K$ ]6 m( B8 o
.Cells(I, C + 6).Value = "黄"
3 c8 W) e& ?3 s! {0 {! y5 @- \% ? ? Case 3
; ^- G+ e; k8 F( f9 C .Cells(I, C + 6).Value = "绿"
" j! N9 m9 L2 x8 ~ Case 4
; r. p* O7 U+ r& I .Cells(I, C + 6).Value = "青"1 F9 ?* i" V8 r4 C; G
Case 5
. |4 }! V0 n/ V& y' d .Cells(I, C + 6).Value = "蓝"
# @: H, Y: ~1 ~9 w: u( f) m Case 6
& L3 e1 x1 N5 }$ F; a, ` .Cells(I, C + 6).Value = "洋红"$ h: d) P' p5 J0 W3 U+ [ p
Case 7
. s/ e' q% |. _' P: y .Cells(I, C + 6).Value = "白"
U" a$ z9 U1 u2 P7 y Case Else '无名称的索引颜色在第7列填写索引号
- F0 E/ t5 e" Y# x; N3 W .Cells(I, C + 6).Value = "索引颜色" & Ly.TrueColor.ColorIndex; c p1 H% R8 F7 Y( R" }
End Select& R5 @8 T! f" h7 O- p' r/ k
End Select8 R4 v1 l& Q% H- `5 X g: G$ o* ~
.Cells(I, C + 7).Value = Ly.Linetype '第8列填写线型名称
8 w5 V8 |6 W! S Select Case Ly.Lineweight '第9列填写线宽
- I- U% M- q' E- M! X& F0 V Case -3 '- k; l. f: w. Q
.Cells(I, C + 8).Value = "默认"2 W7 ~9 g& J& G" e$ ^
Case Else
+ d1 z L1 g- `" U .Cells(I, C + 8).Value = Val(Ly.Lineweight) / 1002 v' }! M7 _9 \4 A
End Select
$ w" h% ~1 S, q1 m .Cells(I, C + 9).Value = Ly.PlotStyleName '第10列填写打印样式名称 V7 U- X2 B7 U {1 o% O
If Ly.Plottable Then .Cells(I, C + 10).Value = "打印" Else .Cells(I, C + 10).Value = "不打印" '第11列填写是否打印" A1 ~5 O) I- p- w* o- Y; m
.Cells(I, C + 11).Value = Ly.Description '第12列填写图层说明
" S8 _) q$ Y2 M, T, F Next
w1 G$ |6 q- R6 Z .Range(.Cells(R, C), .Cells(I, C + 11)).Columns.AutoFit '最适合的列宽
6 r- x$ \# q6 g( L1 s% c& z End With
9 L1 l: { c6 r; c2 S& ]$ n) {. REnd Sub
$ A3 X7 h, h) _' C/ |'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
! u8 `( T' f; l% r: W
( A5 E+ F5 o' v1 e运行结果3 d* d7 f7 A1 b1 T
|
评分
-
查看全部评分
|
发表于 2008-6-17 11:38:22
发表于 2009-2-26 14:47:11