|
|
马上注册，结识高手，享用更多资源，轻松玩转三维网社区。
您需要 登录 才可以下载或查看，没有帐号？注册
x
使用方法：“Alt+F11”打开“VBA编辑器”，单击“工具”菜单，单击“引用”，在弹出的“引用－ACADObject”对话框中寻找并选中Microsoft Excel类型库(比如本机安装的Excel是2000版，引用的类型库就是“Microsoft Excel 9.0 Object Library”)。“确定”后退出对话框。双击“工程资源管理器”中的“ThisDrawing”对象，在弹出的代码窗口粘贴下面代码，“F5”运行。/ L, N# [5 O2 j/ c
' s7 `9 L; C I1 G; p9 p& {! a'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''', P( K& c8 n* |# Y; \- M) ^
Sub TC()
7 n7 s8 l1 ^% A Dim R As Integer, C As Integer, I As Integer, Ly As AcadLayer# Z# n6 `% u& J8 @5 y
Dim xlApp As Excel.Application, xlBook As Excel.Workbook5 S/ J+ R/ Q) Z/ \6 I% A1 U
. i" Q7 ~* i3 S
R = 1: C = 1 '从工作表的第1行第1列开始填写，使用者自行更改
p- _1 [; ~1 B
& O2 s! O6 E8 _% L2 j Set xlApp = CreateObject("Excel.Application") '打开EXCEL程序5 l" E) D' X% A
xlApp.Visible = True '使EXCEL程序可见5 Q' C5 g- H. e2 c: N1 A
Set xlBook = xlApp.Workbooks.Add '插入新工作薄0 r4 \4 ]( `$ Q( s
With xlBook.ActiveSheet
% n2 x/ s7 J6 j/ }. ?3 Y _ .Name = "图层信息" '重命名当前工作表) ?$ Q C1 H5 G- @% n
I = R
: [( A) ]! }# N/ d3 f7 \ .Range(.Cells(I, C), .Cells(I, C + 11)).HorizontalAlignment = xlCenter '所有填写项目名称的单元格水平中心对齐( B R! ?6 E6 S- _; A
.Cells(I, C).Value = "序号" '以下代码逐列填写项目名称' }" L4 i+ A; E" s; R
.Cells(I, C + 1).Value = "状态"$ ?3 T& P! g, B* ?- F; l, v. g
.Cells(I, C + 2).Value = "名称"' _ q4 p+ M% n. {- q- s' h# [ F
.Cells(I, C + 3).Value = "开关"
) \4 \/ s0 C7 \- m3 | h .Cells(I, C + 4).Value = "冻结"
# ^' k; `- o* d ~ .Cells(I, C + 5).Value = "锁定"
' W: m* |! |/ P- |4 V" E& I4 \/ V) V .Cells(I, C + 6).Value = "颜色"
& p9 N# {# ~+ b .Cells(I, C + 7).Value = "线型"# Y. z* r! X6 v, q; w
.Cells(I, C + 8).Value = "线宽"
9 r" c2 y. s* q/ R) t0 W2 E .Cells(I, C + 9).Value = "打印样式"
. g& C( T, d: L& N( c! D! j .Cells(I, C + 10).Value = "打印"5 d: o J, A5 k3 p. s4 Y# R: }4 u
.Cells(I, C + 11).Value = "说明"
5 `& r G% O9 Q( {& q0 b# b5 ~ For Each Ly In ThisDrawing.Layers '遍历图层
" d3 ]+ F& y( F$ R9 }" ^3 i I = I + 1 '在下一行填写该图层信息7 G$ h0 k) u5 a! c
.Range(.Cells(I, C), .Cells(I, C + 10)).HorizontalAlignment = xlCenter '前11项信息所在单元格水平中心对齐
: |; y. J. i" P# x .Cells(I, C + 11).HorizontalAlignment = xlLeft '填写图层说明的单元格水平左对齐; d; V( K3 i4 P& m& g
.Cells(I, C).Value = I - 1 '在第1列填写序号
0 y5 D( ?0 U( Y) u+ }' S5 K If Ly.Used Then .Cells(I, C + 1).Value = "已使用" Else .Cells(I, C + 1).Value = "未使用" '第2列填写使用状态
& r/ d9 X& m4 {* ? .Cells(I, C + 2).Value = Ly.Name '第3列填写图层名称) J/ D( _* f& e* }
If Ly.LayerOn Then .Cells(I, C + 3).Value = "开" Else .Cells(I, C + 3).Value = "关" '第4列填写开关状态/ b9 X' ?1 s4 V
If Ly.Freeze Then .Cells(I, C + 4).Value = "已冻结" Else .Cells(I, C + 4).Value = "未冻结" '第5列填写冻结状态
8 M: u3 l2 x, j: A& e3 G; { If Ly.Lock Then .Cells(I, C + 5).Value = "已锁定" Else .Cells(I, C + 5).Value = "未锁定" '第6列填写锁定状态
" A) q2 S0 h9 {6 T) D1 p" U: O Select Case Ly.TrueColor.ColorMethod '检查颜色定义的方法$ H( R& ^; ^0 F# o* i# k+ }& }
Case 194 '该图层颜色定义为RGB颜色时，在第7列填写RGB颜色1 _$ _( |( g" H+ V' x: `2 B
.Cells(I, C + 6).Value = "RGB颜色" & Ly.TrueColor.Red & "," & Ly.TrueColor.Green & "," & Ly.TrueColor.Blue
% q- O4 E) i& t2 Y1 s9 u Case 195 '该图层颜色定义为索引颜色时
- e% \8 W& J! o+ z Select Case Ly.TrueColor.ColorIndex, \8 ^6 h1 m ]' ^: `3 k
Case 1 '以下代码按索引号在第7列填写颜色名称1 [* s" l; H s
.Cells(I, C + 6).Value = "红"
. Z6 t8 w+ X/ e* w8 q2 c Case 2
' [9 V& o! p- r .Cells(I, C + 6).Value = "黄"
+ h% l+ z. F+ N! M- ]0 ` Case 3" F" J( ]* T7 ~* |0 V
.Cells(I, C + 6).Value = "绿"
* O9 \* N3 {; [+ _& D! i Case 4
' ^* ` T4 i! R .Cells(I, C + 6).Value = "青": p) f$ |, U: o- O2 K9 h/ x
Case 5) F8 z ^2 K7 r& h( N
.Cells(I, C + 6).Value = "蓝"8 R5 O7 _9 C$ Y2 F8 H$ T
Case 6
9 g) B- b, y; G( ?8 t7 D t .Cells(I, C + 6).Value = "洋红"1 y% X& v3 J- P, B
Case 7
; }* \+ f( v, y/ O# c' z/ | .Cells(I, C + 6).Value = "白"; C* n. P$ P% B# p
Case Else '无名称的索引颜色在第7列填写索引号
' R% p: }/ ~, Y0 p! P .Cells(I, C + 6).Value = "索引颜色" & Ly.TrueColor.ColorIndex2 K, @! K6 L) x/ V2 U$ u
End Select
. {- E \$ c* [! u2 E# g End Select$ U" j/ F7 \. T5 a: J/ F
.Cells(I, C + 7).Value = Ly.Linetype '第8列填写线型名称
4 ^! l# k* \& c- h; e Select Case Ly.Lineweight '第9列填写线宽
+ o/ Y7 l5 a# V# B Case -3 '
; N) }2 J- i2 [0 M ~7 Y, F# X .Cells(I, C + 8).Value = "默认"
" D7 t9 k- t* i1 \! Y0 @' @ Case Else
$ b5 v- ]/ Y4 ]1 g: B .Cells(I, C + 8).Value = Val(Ly.Lineweight) / 100+ E4 i- j( X& b1 k- X) ]3 O
End Select9 O# h, u+ J+ i/ K7 \7 b
.Cells(I, C + 9).Value = Ly.PlotStyleName '第10列填写打印样式名称
; ], T" B/ J* ^7 i/ B. |3 M If Ly.Plottable Then .Cells(I, C + 10).Value = "打印" Else .Cells(I, C + 10).Value = "不打印" '第11列填写是否打印8 w% N2 g1 W2 d- e$ y7 X
.Cells(I, C + 11).Value = Ly.Description '第12列填写图层说明* {& h5 I1 L: v' o# G- J4 W
Next& C( ?" Y! i) m4 K
.Range(.Cells(R, C), .Cells(I, C + 11)).Columns.AutoFit '最适合的列宽 h' u W# u( K5 f! {6 a
End With0 ]$ a" n& \! w8 o5 Z% a4 l
End Sub. E$ j7 |; V5 v
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''; e3 J: o( k/ T8 O
: S. W8 C; N2 I' g, A运行结果
' A( T& s5 v& v& E0 |( ~. O
|
评分
-
查看全部评分
|
发表于 2008-6-17 11:38:22
发表于 2009-2-26 14:47:11