|
|
马上注册，结识高手，享用更多资源，轻松玩转三维网社区。
您需要 登录 才可以下载或查看，没有帐号？注册
x
使用方法：“Alt+F11”打开“VBA编辑器”，单击“工具”菜单，单击“引用”，在弹出的“引用－ACADObject”对话框中寻找并选中Microsoft Excel类型库(比如本机安装的Excel是2000版，引用的类型库就是“Microsoft Excel 9.0 Object Library”)。“确定”后退出对话框。双击“工程资源管理器”中的“ThisDrawing”对象，在弹出的代码窗口粘贴下面代码，“F5”运行。% k8 ]2 l: l; J, o$ ^3 Z
3 H' K$ A R, D% g7 x/ d
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''- F& h9 ~3 O" \8 x3 g; A1 p) I
Sub TC()* P7 W4 q) i0 h/ D8 v
Dim R As Integer, C As Integer, I As Integer, Ly As AcadLayer
( \$ m2 ]( L& x, |5 @( l Dim xlApp As Excel.Application, xlBook As Excel.Workbook
. D" ^+ Y7 J2 r. v* Y. n 9 L0 T3 P) o+ n
R = 1: C = 1 '从工作表的第1行第1列开始填写，使用者自行更改3 v. G7 a( C( v6 M( z1 M: F. r4 }5 W
! M% P! B3 T& ?# o. g
Set xlApp = CreateObject("Excel.Application") '打开EXCEL程序2 b3 b5 h2 X) H, e( W
xlApp.Visible = True '使EXCEL程序可见
! r) T6 L4 x% Y% G2 @! a Set xlBook = xlApp.Workbooks.Add '插入新工作薄: P# r6 _7 U: U6 `! R* y1 X2 |) t
With xlBook.ActiveSheet
, v1 n8 A1 {, |* I .Name = "图层信息" '重命名当前工作表
, e7 i0 j) p3 E3 y$ ] I = R
* t4 t. ~0 G$ p+ j+ w% _! u2 I& N .Range(.Cells(I, C), .Cells(I, C + 11)).HorizontalAlignment = xlCenter '所有填写项目名称的单元格水平中心对齐6 b" t. C* A6 B+ _8 @
.Cells(I, C).Value = "序号" '以下代码逐列填写项目名称/ z1 {+ p# z4 ]! O+ m
.Cells(I, C + 1).Value = "状态"# C0 E* H7 ?' U( [, k- o
.Cells(I, C + 2).Value = "名称"
& f" E: H) ^: Q( Q1 ?/ x .Cells(I, C + 3).Value = "开关"
8 m# m! T' [% e# |* q .Cells(I, C + 4).Value = "冻结"9 x4 n! ^, i, S; r4 c' g) |
.Cells(I, C + 5).Value = "锁定") n8 q% Z% ]' j' a- ~! H
.Cells(I, C + 6).Value = "颜色"
* g9 Q' u3 n+ p .Cells(I, C + 7).Value = "线型"
3 V" m# t7 e% B3 x; d. i! c .Cells(I, C + 8).Value = "线宽"
8 ~: o# g. e, i+ a- i6 K3 e .Cells(I, C + 9).Value = "打印样式"# t+ v# K' v7 @6 M, i! G
.Cells(I, C + 10).Value = "打印"
" Z( z; v8 N. W8 G+ V .Cells(I, C + 11).Value = "说明"
9 C- {& y2 |4 ? For Each Ly In ThisDrawing.Layers '遍历图层
[' q( x" A+ P I = I + 1 '在下一行填写该图层信息
' n- t, I; `, k0 ~- [ .Range(.Cells(I, C), .Cells(I, C + 10)).HorizontalAlignment = xlCenter '前11项信息所在单元格水平中心对齐
9 c2 P- n" ?, U$ [6 v% N% v1 k, N .Cells(I, C + 11).HorizontalAlignment = xlLeft '填写图层说明的单元格水平左对齐
+ J& u* a+ S+ d# v .Cells(I, C).Value = I - 1 '在第1列填写序号 }# w! P: Q( S |' M2 X
If Ly.Used Then .Cells(I, C + 1).Value = "已使用" Else .Cells(I, C + 1).Value = "未使用" '第2列填写使用状态 O; l; l% q7 s0 I! \
.Cells(I, C + 2).Value = Ly.Name '第3列填写图层名称
2 I, l' {9 j1 }, F$ ^( l! ^ If Ly.LayerOn Then .Cells(I, C + 3).Value = "开" Else .Cells(I, C + 3).Value = "关" '第4列填写开关状态/ s: H K0 t5 X" Y2 @
If Ly.Freeze Then .Cells(I, C + 4).Value = "已冻结" Else .Cells(I, C + 4).Value = "未冻结" '第5列填写冻结状态
5 ~2 B7 `! b) z$ k0 T& e7 K% M If Ly.Lock Then .Cells(I, C + 5).Value = "已锁定" Else .Cells(I, C + 5).Value = "未锁定" '第6列填写锁定状态
9 g6 L0 S' C, e# U$ q- s Select Case Ly.TrueColor.ColorMethod '检查颜色定义的方法
9 C. ]% c- {1 l% ^ Case 194 '该图层颜色定义为RGB颜色时，在第7列填写RGB颜色
$ K/ W/ b V* m* q D. r* |3 d .Cells(I, C + 6).Value = "RGB颜色" & Ly.TrueColor.Red & "," & Ly.TrueColor.Green & "," & Ly.TrueColor.Blue' S# E2 d6 M- T
Case 195 '该图层颜色定义为索引颜色时# _( V/ \6 a8 Z; {* U
Select Case Ly.TrueColor.ColorIndex
7 ?. ~' W0 C, g Case 1 '以下代码按索引号在第7列填写颜色名称" V& T) S1 E0 T' U8 H7 Q( Y
.Cells(I, C + 6).Value = "红"0 E: S c* A9 m( x/ c$ ?* l
Case 2& G3 u3 T( d. c2 v: V2 D
.Cells(I, C + 6).Value = "黄"; [1 ~7 k6 {# {, R: w, a
Case 3
$ Y$ A( D7 T/ o+ f .Cells(I, C + 6).Value = "绿"
]1 `6 C* ^! B$ g/ E; X Case 4
) ~; [8 v/ _, b7 R4 H8 ?/ K' T- M .Cells(I, C + 6).Value = "青"* p/ U0 o, a/ s) c8 X% D; F
Case 5
$ b$ D i# R: g' _, _ .Cells(I, C + 6).Value = "蓝"
% t: z3 r7 h' r; H0 Y$ g$ C, J Case 6
; E8 t/ z( ?5 z4 B0 y3 _ .Cells(I, C + 6).Value = "洋红"
$ j& T2 N# [ D+ K0 _- y, C Case 7
- h; x* }0 R. I$ _2 S$ V7 }& [9 T .Cells(I, C + 6).Value = "白", L, Q" p8 M/ x( q
Case Else '无名称的索引颜色在第7列填写索引号% ^; q! Q5 X2 p/ P
.Cells(I, C + 6).Value = "索引颜色" & Ly.TrueColor.ColorIndex% Q/ p" h2 t+ e6 I$ H/ r
End Select% Y6 H! {* B; m! ?
End Select4 E9 O- X' `; Y: @, ~
.Cells(I, C + 7).Value = Ly.Linetype '第8列填写线型名称) A: X1 E- g" Z+ ^, L7 [4 J" ?
Select Case Ly.Lineweight '第9列填写线宽
! x J+ b5 I/ e Case -3 '
9 T4 p9 x; s% _. N5 Q0 z1 T .Cells(I, C + 8).Value = "默认") B+ ?& h( j/ K U: {
Case Else+ f- o5 a- a/ ]$ Z, V" E& x! c
.Cells(I, C + 8).Value = Val(Ly.Lineweight) / 100! \: {4 Y( U$ h
End Select
4 m& j0 f* @. t2 a; E0 a .Cells(I, C + 9).Value = Ly.PlotStyleName '第10列填写打印样式名称
) U$ x. w8 ?+ r If Ly.Plottable Then .Cells(I, C + 10).Value = "打印" Else .Cells(I, C + 10).Value = "不打印" '第11列填写是否打印
. d9 d/ q, I3 T4 Q% B8 v( x .Cells(I, C + 11).Value = Ly.Description '第12列填写图层说明0 w- i& z& T( f5 T* \+ D
Next
. o, H, U+ J3 }" Q6 D .Range(.Cells(R, C), .Cells(I, C + 11)).Columns.AutoFit '最适合的列宽
: k w+ ?* v. w6 b End With
M1 j: ~! o4 U. |1 }End Sub. m. g& Z. K b
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''; ]* M- T, J b4 W
/ \% C2 ]3 [. f4 x运行结果2 J2 g/ x5 Y: I7 o8 L; `8 g! W8 _
|
评分
-
查看全部评分
|
发表于 2008-6-17 11:38:22
发表于 2009-2-26 14:47:11