|
|
马上注册，结识高手，享用更多资源，轻松玩转三维网社区。
您需要 登录 才可以下载或查看，没有帐号？注册
x
使用方法：“Alt+F11”打开“VBA编辑器”，单击“工具”菜单，单击“引用”，在弹出的“引用－ACADObject”对话框中寻找并选中Microsoft Excel类型库(比如本机安装的Excel是2000版，引用的类型库就是“Microsoft Excel 9.0 Object Library”)。“确定”后退出对话框。双击“工程资源管理器”中的“ThisDrawing”对象，在弹出的代码窗口粘贴下面代码，“F5”运行。6 R% y$ \; w! h$ i" F6 \
+ y3 V1 u0 b8 _: q ~, _'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''') {# d" L/ l: f4 \
Sub TC()0 J" |. J* g i7 X9 B
Dim R As Integer, C As Integer, I As Integer, Ly As AcadLayer
, e$ R5 Q: G( G0 I0 [0 e8 h Dim xlApp As Excel.Application, xlBook As Excel.Workbook
' _: w) g. | d0 q- q2 O
# o; B: Y3 V% `/ {; m" r R = 1: C = 1 '从工作表的第1行第1列开始填写，使用者自行更改
* r. B. h S z0 ?8 F : K. c4 J5 u. _3 ?2 Y
Set xlApp = CreateObject("Excel.Application") '打开EXCEL程序
# A$ J" m7 ~/ f6 c1 M9 v xlApp.Visible = True '使EXCEL程序可见
w2 ?' Q5 E% U0 Q3 K Set xlBook = xlApp.Workbooks.Add '插入新工作薄* ^& n L' w* Z0 D% N9 ^& l
With xlBook.ActiveSheet
2 i9 `/ l) a" _3 M: d- s9 u# p( ^ S .Name = "图层信息" '重命名当前工作表$ j1 l& x0 F- G% X
I = R
# g- T/ s5 V: _- P; _" G0 T# s1 Y .Range(.Cells(I, C), .Cells(I, C + 11)).HorizontalAlignment = xlCenter '所有填写项目名称的单元格水平中心对齐$ i" x2 X, ?9 I% R; |% ?4 W
.Cells(I, C).Value = "序号" '以下代码逐列填写项目名称
5 W# _3 W1 ]4 d/ }+ r$ ?$ R .Cells(I, C + 1).Value = "状态"
; f T( Q6 q' W: H. T7 {- U .Cells(I, C + 2).Value = "名称"
J- l3 @% Y; y .Cells(I, C + 3).Value = "开关"
) e/ w. _: B, A0 Y9 T .Cells(I, C + 4).Value = "冻结"/ l1 u" i% x* b, E* s( F+ ^
.Cells(I, C + 5).Value = "锁定": e* k2 O, S' S5 k# d
.Cells(I, C + 6).Value = "颜色"6 c9 l: E/ T6 X8 [5 {/ w3 s
.Cells(I, C + 7).Value = "线型"
5 R7 d6 |# U2 b f! R" T .Cells(I, C + 8).Value = "线宽"; `: G$ e2 j' h5 ~* X e m# r
.Cells(I, C + 9).Value = "打印样式"
6 s/ @9 J+ K9 f: c2 H2 u .Cells(I, C + 10).Value = "打印"+ G% Q* U7 F) C" `1 G3 L
.Cells(I, C + 11).Value = "说明"
3 K/ Q4 g K8 W2 H& z For Each Ly In ThisDrawing.Layers '遍历图层
0 ^2 l% m( z4 b$ Y1 f I = I + 1 '在下一行填写该图层信息
9 L: U: w# Y9 c- _ [ m .Range(.Cells(I, C), .Cells(I, C + 10)).HorizontalAlignment = xlCenter '前11项信息所在单元格水平中心对齐# K1 \5 M/ U7 i8 G3 U6 Q9 l
.Cells(I, C + 11).HorizontalAlignment = xlLeft '填写图层说明的单元格水平左对齐9 @' L# P6 n0 J" o/ \
.Cells(I, C).Value = I - 1 '在第1列填写序号) O7 u4 \9 ^* B7 A& Y1 S
If Ly.Used Then .Cells(I, C + 1).Value = "已使用" Else .Cells(I, C + 1).Value = "未使用" '第2列填写使用状态- p+ L. v: s6 z4 a4 k5 |' C
.Cells(I, C + 2).Value = Ly.Name '第3列填写图层名称
) N5 t2 b, D7 J3 |- \ If Ly.LayerOn Then .Cells(I, C + 3).Value = "开" Else .Cells(I, C + 3).Value = "关" '第4列填写开关状态 V4 g4 G( Z$ W
If Ly.Freeze Then .Cells(I, C + 4).Value = "已冻结" Else .Cells(I, C + 4).Value = "未冻结" '第5列填写冻结状态0 M9 w0 G0 S5 f* W
If Ly.Lock Then .Cells(I, C + 5).Value = "已锁定" Else .Cells(I, C + 5).Value = "未锁定" '第6列填写锁定状态
( Z2 N: Z; i1 T. x* m Select Case Ly.TrueColor.ColorMethod '检查颜色定义的方法
$ }" @, }5 s' s4 H& p1 r2 r' O Case 194 '该图层颜色定义为RGB颜色时，在第7列填写RGB颜色" g6 i/ |; G! \6 k; ~5 I
.Cells(I, C + 6).Value = "RGB颜色" & Ly.TrueColor.Red & "," & Ly.TrueColor.Green & "," & Ly.TrueColor.Blue$ v; t2 P& q/ n
Case 195 '该图层颜色定义为索引颜色时
2 W& s9 U# E7 L- U2 y+ _ Select Case Ly.TrueColor.ColorIndex. y; i1 f5 z" }4 `! E
Case 1 '以下代码按索引号在第7列填写颜色名称* i3 C4 V( T' u6 f4 v
.Cells(I, C + 6).Value = "红"
6 K5 u% A) d% `9 i& S7 F Case 2% f# p- z( v' y: c$ O( c3 U
.Cells(I, C + 6).Value = "黄"
# f! \- ]! r1 O* F+ m/ }$ Y( o Case 3
5 H% p/ b4 F1 v; @5 K- V .Cells(I, C + 6).Value = "绿"
' \! ^: |$ |& l; u2 A. S6 A$ ?. g+ A Case 45 x; c; U. J7 H, J3 V, Y& x
.Cells(I, C + 6).Value = "青"
* I) T8 k& h9 U7 p% s, }' k Case 5$ A# v( ?, e/ h
.Cells(I, C + 6).Value = "蓝"
6 U% e. ~% [+ f Case 62 X* ~9 e! H s x' [: u
.Cells(I, C + 6).Value = "洋红"9 y6 U# g) M& A# j: u
Case 7% x' }2 e8 s, Y, u9 q0 {
.Cells(I, C + 6).Value = "白"9 y7 B( E I6 Z1 l1 S6 X. a3 V
Case Else '无名称的索引颜色在第7列填写索引号( u; l3 }& s& E( u3 v; E
.Cells(I, C + 6).Value = "索引颜色" & Ly.TrueColor.ColorIndex
! t! x2 O% s9 n End Select7 Y* ~5 L" O7 R% V7 m8 p1 Y
End Select
( t* [3 l: Z/ i6 I4 T* p0 A# f .Cells(I, C + 7).Value = Ly.Linetype '第8列填写线型名称3 ~, S, S! J: f j5 {9 o( O) p5 o0 K
Select Case Ly.Lineweight '第9列填写线宽5 Y, N* v, Y( S! X% f1 c7 E
Case -3 '8 i. c. J0 p- q
.Cells(I, C + 8).Value = "默认"( T, u9 ^8 X# M! W- D/ L
Case Else
9 C+ ]( Q* Z; @) d8 \ .Cells(I, C + 8).Value = Val(Ly.Lineweight) / 100- j3 ~. d9 R$ L. H
End Select
4 R, i% h' p" r7 y0 m .Cells(I, C + 9).Value = Ly.PlotStyleName '第10列填写打印样式名称
8 h7 @$ Y: N H# g2 a7 ]! E* J; x If Ly.Plottable Then .Cells(I, C + 10).Value = "打印" Else .Cells(I, C + 10).Value = "不打印" '第11列填写是否打印/ y% Y2 `) S$ o1 S4 |8 M+ i
.Cells(I, C + 11).Value = Ly.Description '第12列填写图层说明* w- Z, Q4 x- I% N+ ^! E) ^
Next6 A7 s" m5 D `9 `$ c
.Range(.Cells(R, C), .Cells(I, C + 11)).Columns.AutoFit '最适合的列宽
% Y P! P/ k: @/ y8 o End With; J! f, N% l& W" v* K
End Sub
$ m0 Y" B5 d% g$ J3 `! I, w'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''( y5 j" ?0 B9 C8 @' [( g& p, f
" l8 [& w( G! @% b7 n0 m; g
运行结果
* Q f5 s; h% N5 ^
|
评分
-
查看全部评分
|
发表于 2008-6-17 11:38:22
发表于 2009-2-26 14:47:11