|
|
马上注册，结识高手，享用更多资源，轻松玩转三维网社区。
您需要 登录 才可以下载或查看，没有帐号？注册
x
使用方法：“Alt+F11”打开“VBA编辑器”，单击“工具”菜单，单击“引用”，在弹出的“引用－ACADObject”对话框中寻找并选中Microsoft Excel类型库(比如本机安装的Excel是2000版，引用的类型库就是“Microsoft Excel 9.0 Object Library”)。“确定”后退出对话框。双击“工程资源管理器”中的“ThisDrawing”对象，在弹出的代码窗口粘贴下面代码，“F5”运行。
; u* A0 I( H8 E" S. \2 p1 \9 ^1 w d7 c
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''! B- a, s1 Q% p) p; W( F# q
Sub TC()% s/ U/ y& Y4 G# [ W# M
Dim R As Integer, C As Integer, I As Integer, Ly As AcadLayer
% g3 S! L" m- _( a! k+ s Dim xlApp As Excel.Application, xlBook As Excel.Workbook' A2 X2 u6 f; E- L G8 k, F- K+ ^2 I
1 ~9 O: D! A+ f/ Y. M: `# c: \0 d9 T
R = 1: C = 1 '从工作表的第1行第1列开始填写，使用者自行更改
/ m. ]+ d$ g2 w* H. C6 |
% Q8 t% _7 N1 x# D/ K, ^/ N Set xlApp = CreateObject("Excel.Application") '打开EXCEL程序- H' x# l! ~8 `: `
xlApp.Visible = True '使EXCEL程序可见
! W f G7 {& _+ A y/ C. L. B/ ?. } Set xlBook = xlApp.Workbooks.Add '插入新工作薄
/ @4 @4 p* C1 `! p+ c! E With xlBook.ActiveSheet
$ m: _8 ~2 s! e; B+ G2 t .Name = "图层信息" '重命名当前工作表, n, R: D1 v0 N! Y- f: U; S
I = R% K* |% K) c& ~
.Range(.Cells(I, C), .Cells(I, C + 11)).HorizontalAlignment = xlCenter '所有填写项目名称的单元格水平中心对齐7 `& p: W) H1 @: @; ?0 O
.Cells(I, C).Value = "序号" '以下代码逐列填写项目名称
$ b6 o; ]1 D0 u7 N7 u/ r$ S .Cells(I, C + 1).Value = "状态"
[* c" F) h2 V; S .Cells(I, C + 2).Value = "名称"2 g/ U3 }% u H: k. |$ E" A& v7 n
.Cells(I, C + 3).Value = "开关"+ m4 ~" B: S6 o6 t0 a
.Cells(I, C + 4).Value = "冻结"1 s8 z3 Q& L+ t, Y1 Y7 c. t
.Cells(I, C + 5).Value = "锁定"& Y {& H' g0 E. H& ]+ } n
.Cells(I, C + 6).Value = "颜色"/ z; G5 W; k! h9 l0 n% Y% p( v% u7 e4 u
.Cells(I, C + 7).Value = "线型"- ^" L+ l' W; D" Z m
.Cells(I, C + 8).Value = "线宽"4 }7 z! [: m; ]0 _# k# H
.Cells(I, C + 9).Value = "打印样式"
9 w8 L0 P1 i9 [: X .Cells(I, C + 10).Value = "打印"2 j- V0 r: C1 Q# x4 n- B6 e* g; d
.Cells(I, C + 11).Value = "说明"* L c/ j4 Q4 v5 o
For Each Ly In ThisDrawing.Layers '遍历图层
2 ]% c2 U) `5 S d I = I + 1 '在下一行填写该图层信息: }9 j' C$ \# r' T+ N* T3 t3 T
.Range(.Cells(I, C), .Cells(I, C + 10)).HorizontalAlignment = xlCenter '前11项信息所在单元格水平中心对齐
1 c9 n: B" A# ~ .Cells(I, C + 11).HorizontalAlignment = xlLeft '填写图层说明的单元格水平左对齐
: {# o& O( U2 l' [" _9 f .Cells(I, C).Value = I - 1 '在第1列填写序号
2 I2 J1 D* f, {# ]/ F) D2 p f If Ly.Used Then .Cells(I, C + 1).Value = "已使用" Else .Cells(I, C + 1).Value = "未使用" '第2列填写使用状态7 i. h- @+ P$ a \, M8 c# s
.Cells(I, C + 2).Value = Ly.Name '第3列填写图层名称
8 D3 w6 q" F7 ^' ]4 G/ k. N } If Ly.LayerOn Then .Cells(I, C + 3).Value = "开" Else .Cells(I, C + 3).Value = "关" '第4列填写开关状态* Y5 }' ~3 _1 h% _1 z4 @
If Ly.Freeze Then .Cells(I, C + 4).Value = "已冻结" Else .Cells(I, C + 4).Value = "未冻结" '第5列填写冻结状态- p# p0 q w4 X4 k& \0 O Y$ I
If Ly.Lock Then .Cells(I, C + 5).Value = "已锁定" Else .Cells(I, C + 5).Value = "未锁定" '第6列填写锁定状态
) c! v6 R" o) @8 _1 I* q# o( h4 W Select Case Ly.TrueColor.ColorMethod '检查颜色定义的方法
2 k. t% f. Z, U, Y4 H9 c, d Case 194 '该图层颜色定义为RGB颜色时，在第7列填写RGB颜色
% ]2 O- E+ \* [% y7 ]- Q .Cells(I, C + 6).Value = "RGB颜色" & Ly.TrueColor.Red & "," & Ly.TrueColor.Green & "," & Ly.TrueColor.Blue' j7 c/ s. x/ a* u+ L$ ]. l7 x
Case 195 '该图层颜色定义为索引颜色时 U3 A& S' z f; j( C0 V) a8 r
Select Case Ly.TrueColor.ColorIndex
9 j4 C# o+ {5 \0 A+ Y Case 1 '以下代码按索引号在第7列填写颜色名称2 r3 z( n6 U# _
.Cells(I, C + 6).Value = "红"
) a7 w8 T' I7 M4 d Case 2
, z* Z: L% \2 Q .Cells(I, C + 6).Value = "黄"! L2 K. y! W8 z6 x. N) @1 R) U
Case 3, }; P) }" J5 s6 U* o
.Cells(I, C + 6).Value = "绿") T% E# ~5 T4 k9 D3 _
Case 4
% F5 F- t/ j$ o .Cells(I, C + 6).Value = "青"
3 ^5 x- s8 I( `9 g' d* W" w Case 5
8 k0 r' c h2 t0 @ .Cells(I, C + 6).Value = "蓝"
5 }8 o; p- g+ \ Case 6
6 @ a& k$ Z- }* o" E+ b# _" k6 ` .Cells(I, C + 6).Value = "洋红": @2 ^5 P, q3 |& Y# l/ [3 d" y7 W" ~
Case 75 o' u( r s7 ^0 }6 z
.Cells(I, C + 6).Value = "白"9 _0 n, V3 d" |, X! E5 E' E5 |
Case Else '无名称的索引颜色在第7列填写索引号
3 L6 k* \9 B, w4 T .Cells(I, C + 6).Value = "索引颜色" & Ly.TrueColor.ColorIndex
2 O1 p) u/ q0 K$ C* K+ N End Select
' @; Y2 E3 y. n! A End Select
& D! K% {. q9 D* W/ f .Cells(I, C + 7).Value = Ly.Linetype '第8列填写线型名称4 r: h& i W& r" `( d
Select Case Ly.Lineweight '第9列填写线宽
% G$ M1 b0 I# _3 k+ O) L/ K7 P5 C" f Case -3 '
' Y4 \: ~( b/ ~: x! w0 C I# ? .Cells(I, C + 8).Value = "默认"
6 f4 w" e- g: N) h+ o Case Else
9 j' k2 v; `! S' Z2 J% [. ` .Cells(I, C + 8).Value = Val(Ly.Lineweight) / 100
0 w- [) ]. b% K2 t# @ End Select
6 z8 U. \ ~4 R- n# p7 m5 ?; e$ x" @ .Cells(I, C + 9).Value = Ly.PlotStyleName '第10列填写打印样式名称% d1 I) U: ]! e
If Ly.Plottable Then .Cells(I, C + 10).Value = "打印" Else .Cells(I, C + 10).Value = "不打印" '第11列填写是否打印8 D* p# A4 u3 ^3 ?0 Q3 M7 |
.Cells(I, C + 11).Value = Ly.Description '第12列填写图层说明
- u c+ q+ ~0 `9 U2 I Next7 y$ q6 d: b! m+ ]! r
.Range(.Cells(R, C), .Cells(I, C + 11)).Columns.AutoFit '最适合的列宽
# F# t- C" Q& O% g End With7 k7 f, J5 O+ j
End Sub
* @1 n! S! H8 s' [0 }5 E'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
1 y1 p, Q1 N% F- V( [1 }6 ~' j! R6 ]2 l! \0 E
运行结果: } x+ Z& ^0 h# k: c$ K. J
|
评分
-
查看全部评分
|
发表于 2008-6-17 11:38:22
发表于 2009-2-26 14:47:11