|
|
马上注册，结识高手，享用更多资源，轻松玩转三维网社区。
您需要 登录 才可以下载或查看，没有帐号？注册
x
使用方法：“Alt+F11”打开“VBA编辑器”，单击“工具”菜单，单击“引用”，在弹出的“引用－ACADObject”对话框中寻找并选中Microsoft Excel类型库(比如本机安装的Excel是2000版，引用的类型库就是“Microsoft Excel 9.0 Object Library”)。“确定”后退出对话框。双击“工程资源管理器”中的“ThisDrawing”对象，在弹出的代码窗口粘贴下面代码，“F5”运行。
" N5 r, b& I0 p+ |7 x) ^
6 t4 E) w0 u' K4 X''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
: l4 T; L) ~) Q' E/ y" VSub TC()
9 T V5 u( h# A! u9 I6 \; j Dim R As Integer, C As Integer, I As Integer, Ly As AcadLayer
1 d. L& [" h$ {5 V p3 l7 S# k8 X Dim xlApp As Excel.Application, xlBook As Excel.Workbook/ K) l- D" L% Q, P* ~2 B
* E" O, H% _4 \. Z+ |! L$ V
R = 1: C = 1 '从工作表的第1行第1列开始填写，使用者自行更改# ?1 T* A! x$ B3 c K3 R) b7 S
z8 q6 y* J; i* \& W
Set xlApp = CreateObject("Excel.Application") '打开EXCEL程序" n# ]% `/ \( G, e% N& D8 \
xlApp.Visible = True '使EXCEL程序可见7 j/ s, s: W8 L6 ~! d) R
Set xlBook = xlApp.Workbooks.Add '插入新工作薄, ]- u, U; h9 g5 r" |" J, B
With xlBook.ActiveSheet7 s6 s8 l, |' w# H7 j- r
.Name = "图层信息" '重命名当前工作表, K; @0 k. r& b& G
I = R
4 `: p' A y5 `+ p. I .Range(.Cells(I, C), .Cells(I, C + 11)).HorizontalAlignment = xlCenter '所有填写项目名称的单元格水平中心对齐
" B/ g) K# m8 @, r! \6 ]1 j6 Z) T .Cells(I, C).Value = "序号" '以下代码逐列填写项目名称0 M. i3 V9 L& ]! k0 O
.Cells(I, C + 1).Value = "状态"
/ z( k! p5 H( h/ j! g' g5 X1 O .Cells(I, C + 2).Value = "名称"$ W5 N; i$ D/ C* F3 N; q
.Cells(I, C + 3).Value = "开关"$ p' A0 r# a# ]4 H6 E
.Cells(I, C + 4).Value = "冻结"
' ?. U+ Q6 ]9 E& s .Cells(I, C + 5).Value = "锁定") c. j' S9 Y% H n5 A) F' J
.Cells(I, C + 6).Value = "颜色"
6 \. }7 J& [2 I$ {+ Z- S W .Cells(I, C + 7).Value = "线型"
- f, p& X, O9 b, j: x2 | .Cells(I, C + 8).Value = "线宽"- i( t3 Q/ b+ [4 b- Q
.Cells(I, C + 9).Value = "打印样式"' _4 C& ?4 N( i
.Cells(I, C + 10).Value = "打印"& B3 {0 |; N+ [* c3 E/ o/ U* d
.Cells(I, C + 11).Value = "说明"
- [. n" i w" `& x For Each Ly In ThisDrawing.Layers '遍历图层* O y0 u4 j' a! B6 C; `
I = I + 1 '在下一行填写该图层信息% X# G1 Q' w1 u) i' E
.Range(.Cells(I, C), .Cells(I, C + 10)).HorizontalAlignment = xlCenter '前11项信息所在单元格水平中心对齐' x9 X, I/ x9 p) h' Q$ C
.Cells(I, C + 11).HorizontalAlignment = xlLeft '填写图层说明的单元格水平左对齐$ Q0 u) }) I7 L7 {( }
.Cells(I, C).Value = I - 1 '在第1列填写序号8 Z. t9 O3 `6 q9 e" ], A
If Ly.Used Then .Cells(I, C + 1).Value = "已使用" Else .Cells(I, C + 1).Value = "未使用" '第2列填写使用状态- }# q' S# e" N: T @
.Cells(I, C + 2).Value = Ly.Name '第3列填写图层名称
: ], v; t$ ^- N3 c If Ly.LayerOn Then .Cells(I, C + 3).Value = "开" Else .Cells(I, C + 3).Value = "关" '第4列填写开关状态
0 Z, q3 R+ _$ s5 F+ `: G0 t If Ly.Freeze Then .Cells(I, C + 4).Value = "已冻结" Else .Cells(I, C + 4).Value = "未冻结" '第5列填写冻结状态
+ v3 P3 ` I N' \& P! [: L7 f If Ly.Lock Then .Cells(I, C + 5).Value = "已锁定" Else .Cells(I, C + 5).Value = "未锁定" '第6列填写锁定状态3 A& J- {" p" Z# f8 ~) L8 b5 I6 V
Select Case Ly.TrueColor.ColorMethod '检查颜色定义的方法6 W0 x1 ^/ O6 {+ l3 l: \7 t( ]- S' p3 _8 F
Case 194 '该图层颜色定义为RGB颜色时，在第7列填写RGB颜色
) K! U+ F% ^& H2 E$ s( L .Cells(I, C + 6).Value = "RGB颜色" & Ly.TrueColor.Red & "," & Ly.TrueColor.Green & "," & Ly.TrueColor.Blue& W7 P& N! |4 I
Case 195 '该图层颜色定义为索引颜色时, `. [! K1 f1 q2 o* y+ e1 \! l* B
Select Case Ly.TrueColor.ColorIndex
# Y9 n& [% _4 s9 Z: n2 ~ Case 1 '以下代码按索引号在第7列填写颜色名称
5 _6 x" }- S! w2 ~ .Cells(I, C + 6).Value = "红"0 N/ ?0 ^/ Z$ R' R6 R
Case 20 j" C7 W& O1 a& o6 L: e
.Cells(I, C + 6).Value = "黄"
# G0 t' q4 e: {# f( i' f" S Case 3; ]6 \( z1 D3 F0 F( V4 a
.Cells(I, C + 6).Value = "绿") D4 @% d1 X) ~9 O0 g
Case 4; u+ ` y! W, X' b' K
.Cells(I, C + 6).Value = "青"
; }) K, G/ ?7 ]9 X- S1 i$ g Case 5
; s! @8 c- u: s .Cells(I, C + 6).Value = "蓝"4 _ H9 l- y* e. N
Case 6! B$ `4 `3 s( ~0 o6 ^( B |% J
.Cells(I, C + 6).Value = "洋红"8 P* F8 Y1 z. M6 X F( ]+ Q& Z( v
Case 7$ D5 y- {, [4 \0 t% o9 `
.Cells(I, C + 6).Value = "白"
/ V5 d. |( e- p' v Case Else '无名称的索引颜色在第7列填写索引号
5 ~% X: S( e8 T .Cells(I, C + 6).Value = "索引颜色" & Ly.TrueColor.ColorIndex
: ^8 L- q: J! ~/ ]- e' h End Select! p/ f- F0 n- b2 A! z" x
End Select
5 c% C5 Z2 k4 }* h .Cells(I, C + 7).Value = Ly.Linetype '第8列填写线型名称- A" k4 z) m# k _
Select Case Ly.Lineweight '第9列填写线宽
- V) f; V( s F ]6 M Case -3 '
1 v1 L& z4 V2 c .Cells(I, C + 8).Value = "默认"; X7 l7 f, ~: P9 C1 F
Case Else
- q3 Q( q& ^' x' X .Cells(I, C + 8).Value = Val(Ly.Lineweight) / 100
9 ]0 f, G0 }& `* s4 ] N7 G End Select
- d0 G% ]! O; V9 B8 V .Cells(I, C + 9).Value = Ly.PlotStyleName '第10列填写打印样式名称
5 f$ \# Q* s" N9 e+ C0 u& _6 M" Q% u If Ly.Plottable Then .Cells(I, C + 10).Value = "打印" Else .Cells(I, C + 10).Value = "不打印" '第11列填写是否打印' [: R H# k# N
.Cells(I, C + 11).Value = Ly.Description '第12列填写图层说明
! N2 H2 Z9 B2 S! S Next5 |- P" K) ~" F0 Q
.Range(.Cells(R, C), .Cells(I, C + 11)).Columns.AutoFit '最适合的列宽. v. C) T. R% F5 `
End With
& `) `7 C) h U, n! [4 F& J) EEnd Sub0 P& P0 T; y% ?
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''( c( p2 d9 b; Y9 ?
) N! l2 L! Y9 O) G* @: T1 B! k
运行结果: A. j' |$ j$ p, J. Y
|
评分
-
查看全部评分
|
发表于 2008-6-17 11:38:22
发表于 2009-2-26 14:47:11