|
|
马上注册，结识高手，享用更多资源，轻松玩转三维网社区。
您需要 登录 才可以下载或查看，没有帐号？注册
x
使用方法：“Alt+F11”打开“VBA编辑器”，单击“工具”菜单，单击“引用”，在弹出的“引用－ACADObject”对话框中寻找并选中Microsoft Excel类型库(比如本机安装的Excel是2000版，引用的类型库就是“Microsoft Excel 9.0 Object Library”)。“确定”后退出对话框。双击“工程资源管理器”中的“ThisDrawing”对象，在弹出的代码窗口粘贴下面代码，“F5”运行。
0 C# C: O( r: v6 R: k+ T; s3 Z
, w4 e! f, b) u) f. ]! y* ]4 {''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
3 @" }. {4 o7 A fSub TC()
# J7 b8 S" T, Z1 r' _ x+ K Dim R As Integer, C As Integer, I As Integer, Ly As AcadLayer
" }, k" Z- @% l- a0 H4 X Dim xlApp As Excel.Application, xlBook As Excel.Workbook8 O: [9 m& H7 v: C, @
8 a* c c9 q& f" E2 K2 m R = 1: C = 1 '从工作表的第1行第1列开始填写，使用者自行更改4 m2 G7 B4 L/ x3 @8 `! Q6 Q
& x- D, u, |$ ?: F1 \, \( f1 w& x Set xlApp = CreateObject("Excel.Application") '打开EXCEL程序
" ^ C& R1 d% V( |' J/ X xlApp.Visible = True '使EXCEL程序可见
! f- h. n4 ?: E7 ^4 V/ n6 \ Set xlBook = xlApp.Workbooks.Add '插入新工作薄8 x+ ~6 c; W' D3 N+ F
With xlBook.ActiveSheet; o: F# s5 j+ U. V
.Name = "图层信息" '重命名当前工作表; r2 ]* D) u0 q+ v; Q8 K t+ p6 p' f
I = R, P. J; d$ H4 ?* ?/ U5 n/ _3 `% w
.Range(.Cells(I, C), .Cells(I, C + 11)).HorizontalAlignment = xlCenter '所有填写项目名称的单元格水平中心对齐- x, @7 ^$ q( w( \8 E5 C9 f
.Cells(I, C).Value = "序号" '以下代码逐列填写项目名称
8 g: o3 D1 n0 g" C) h- B7 E .Cells(I, C + 1).Value = "状态"
4 P( R! n# i# h) y" ~ .Cells(I, C + 2).Value = "名称"& b0 |5 d. q$ C5 F% p+ b% y+ `
.Cells(I, C + 3).Value = "开关"
3 `2 w+ F0 T( \. q6 F3 G .Cells(I, C + 4).Value = "冻结"
4 Q) }! v4 P2 C. x& B1 [ .Cells(I, C + 5).Value = "锁定"
3 u& A# z) B3 O/ F( Q6 K3 k .Cells(I, C + 6).Value = "颜色"9 d+ B8 S1 T" i# _- M
.Cells(I, C + 7).Value = "线型"
4 q5 e, U" @0 x- Q( d .Cells(I, C + 8).Value = "线宽"
' S2 l! Z0 k: K7 [7 }4 m7 C) W .Cells(I, C + 9).Value = "打印样式"
1 L* Z1 e2 d9 ^, ]) |4 l .Cells(I, C + 10).Value = "打印"
% b! n6 s! E; i. o: C. W- M5 l( v5 } .Cells(I, C + 11).Value = "说明"+ q6 p, H* l/ B* G
For Each Ly In ThisDrawing.Layers '遍历图层2 L. m4 D/ i v# g6 k
I = I + 1 '在下一行填写该图层信息
% W$ z0 q( m; D3 a .Range(.Cells(I, C), .Cells(I, C + 10)).HorizontalAlignment = xlCenter '前11项信息所在单元格水平中心对齐, x- p4 Y; M8 d
.Cells(I, C + 11).HorizontalAlignment = xlLeft '填写图层说明的单元格水平左对齐1 p4 a7 H" I) r: `0 y# l
.Cells(I, C).Value = I - 1 '在第1列填写序号
! U' Y5 _2 ~) R4 d If Ly.Used Then .Cells(I, C + 1).Value = "已使用" Else .Cells(I, C + 1).Value = "未使用" '第2列填写使用状态) I% f% M6 ~( Z! U; t+ Y
.Cells(I, C + 2).Value = Ly.Name '第3列填写图层名称
! Z N1 }7 G% u If Ly.LayerOn Then .Cells(I, C + 3).Value = "开" Else .Cells(I, C + 3).Value = "关" '第4列填写开关状态
, T% }) g' S$ } If Ly.Freeze Then .Cells(I, C + 4).Value = "已冻结" Else .Cells(I, C + 4).Value = "未冻结" '第5列填写冻结状态0 _+ P2 J/ }# s" L
If Ly.Lock Then .Cells(I, C + 5).Value = "已锁定" Else .Cells(I, C + 5).Value = "未锁定" '第6列填写锁定状态
. b5 V: z L2 r# {, y" P Select Case Ly.TrueColor.ColorMethod '检查颜色定义的方法
3 Y2 k. P4 X5 q6 d* n) A Case 194 '该图层颜色定义为RGB颜色时，在第7列填写RGB颜色* X C) Q+ T; {' o
.Cells(I, C + 6).Value = "RGB颜色" & Ly.TrueColor.Red & "," & Ly.TrueColor.Green & "," & Ly.TrueColor.Blue8 r5 q+ k( t* b& m) g
Case 195 '该图层颜色定义为索引颜色时
% m1 M( }# ?0 S4 l o7 E Select Case Ly.TrueColor.ColorIndex6 n) @% N8 T- r) [: u7 X
Case 1 '以下代码按索引号在第7列填写颜色名称
3 f3 r( S. N- ]6 O: H6 @* P: W: \ .Cells(I, C + 6).Value = "红"( A2 |) d# C3 t0 V- B4 N3 a
Case 26 j1 j" d" F; e8 L" U; r
.Cells(I, C + 6).Value = "黄"* n8 F( ^8 n- }
Case 3" s( a' D& X6 i7 z
.Cells(I, C + 6).Value = "绿"0 Z( a# z: C( ^9 h/ P6 @' _. T+ d. B
Case 4
: H. i l8 B5 _5 X4 l' u6 Y .Cells(I, C + 6).Value = "青"
! Y, b# `5 E( |2 n( v& c Case 5
) y4 y8 N- Y* t* b1 Y( e2 t( U9 F .Cells(I, C + 6).Value = "蓝"
7 w S6 e8 l7 v1 ]+ k% V% @% ?4 w Case 67 |: {! W) z, r1 V5 v) Y
.Cells(I, C + 6).Value = "洋红"
- c+ r/ U3 u! l5 j `' u Case 72 \9 }1 L( n% h+ U& K& Q
.Cells(I, C + 6).Value = "白"& R. M+ g1 w& Q9 F
Case Else '无名称的索引颜色在第7列填写索引号
5 |6 A; |# D+ {7 m .Cells(I, C + 6).Value = "索引颜色" & Ly.TrueColor.ColorIndex2 i3 O$ d$ O9 ^4 U* O
End Select
; r" m6 _, L" B' o. K& Q End Select9 l) s" J( A* Z6 a- ~% ]
.Cells(I, C + 7).Value = Ly.Linetype '第8列填写线型名称) {; m" Y, o0 K$ m# F
Select Case Ly.Lineweight '第9列填写线宽) I" @, V* d( K: u4 v0 Q
Case -3 '' k1 ?( @2 h% b
.Cells(I, C + 8).Value = "默认"7 P; @( T% A7 g+ V6 h9 y6 b2 y; }
Case Else
0 n$ o6 U! M% G .Cells(I, C + 8).Value = Val(Ly.Lineweight) / 100
0 C0 {! w5 g0 _7 u. T/ a" t% v End Select
8 z$ W+ O5 d& l .Cells(I, C + 9).Value = Ly.PlotStyleName '第10列填写打印样式名称3 N+ j$ \+ t. m
If Ly.Plottable Then .Cells(I, C + 10).Value = "打印" Else .Cells(I, C + 10).Value = "不打印" '第11列填写是否打印
9 D* ]& ^, b5 ~: [ .Cells(I, C + 11).Value = Ly.Description '第12列填写图层说明
% c; {+ t$ C# d0 A. J6 t) i Next) ]7 D4 F7 w' a' F' I9 T7 s
.Range(.Cells(R, C), .Cells(I, C + 11)).Columns.AutoFit '最适合的列宽1 ]4 x. ~* z' B* D. b! N- m- m) l/ F
End With
( i/ |. i' c0 S Q2 N. b3 o8 e7 sEnd Sub9 |& |2 b7 k( _* J, U3 [
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
% w% L: @* W9 c% t) C4 Z' [" ]* [, J! |( X4 X
运行结果& A4 N& O6 H; t6 x2 R0 i
|
评分
-
查看全部评分
|
发表于 2008-6-17 11:38:22
发表于 2009-2-26 14:47:11