三维网
标题:
Autocad vbA 初级教程(13) 块操作
[打印本页]
作者:
zzb7240
时间:
2006-9-22 15:59
标题:
Autocad vbA 初级教程(13) 块操作
定义块方法：
, `9 G' U- [3 s, n. W; @) I: j" F
Set blocksobj=ThisDrawing.Blocks.Add(基点, 块名)
" K% U3 O) h4 G# A$ n0 p
把选择集加入块中的方法：
; G6 Q* [+ {3 b1 J& {' ~1 R! ^1 E
ThisDrawing.CopyObjects(选择集,块)
' W1 h( _) L. J
插入块方法：
/ s+ F7 O) b1 @( F) d
ThisDrawing.ModelSpace.InsertBlock(插入点,块名, X轴比例,Y轴比例,Z轴比例, 旋转角度)
! W/ D+ ~2 J7 ]9 H6 ~
画块属性方法：
e; ]( d% e2 N5 P
ThisDrawing.ModelSpace.AddAttribute(文字高度,模式,提示字符, 插入点, 显示字符,默认值)
( N/ A$ u) y7 y1 W# \5 O
一共有五种模式，在输入时会有提示，其中最常用的是“acAttributeModeNormal”普通模式
* `* ]) |! ~. @* W9 }9 ?. H
编程思路：
6 Y/ c. n" {7 u2 V: l
1．定义一个空块
5 n" a, V: G( c! c% {0 b
2．在块中画一段弧（球服衣领）
# k, m, H6 \! X; L$ L
3．画多段线，镜像画出球衣
5 J1 u p- ] E9 s) S
4．画块属性，由于块属性默认的对齐方式是左对齐，而球员号码应该居中，所以必须把块的对齐属性改为居中。但是当这个属性更改时块属性对齐点会自动归零，所以不得不再次更改对齐点属性
7 f& X9 f/ G! i
5．把多段线和属性复制到块中
5 u# U6 P; Y' {2 U( m
6．提示用户点选球员位置和姓名
" ]$ f8 S. ~5 v/ r( X
7．插入块，修改球衣号码属性、球员姓名属性
1 c; h# b7 D( F. v2 Q3 A$ W& j( C3 _
% @. H7 j8 L1 C4 h, m- Z
以下是源码，附有详细的注释，如果有疑问，建议用变量跟踪法研究一下。
, b: N* l: @. Q0 t& E
Sub team()
; i$ r) y6 O1 m3 u; q+ c$ K- P
Dim playerlay As AcadLayer '定义球员图层
4 L3 f1 p: [0 d( ]# C; p
Dim playerblock As AcadBlock '定义块变量
7 U# b: `2 Q7 k$ H% c9 |
Dim arcc(0 To 2) As Double '圆弧圆心
' E% Z2 F8 D5 o: u' b. n! I8 |
Dim linep1(0 To 2) As Double '线条端点1
9 l2 Q9 X8 z) [8 \: ]% z
Dim linep2(0 To 2) As Double '线条端点2
6 s; N! J, f9 l }( n
Dim pline(0 To 20) As Double '定义队服右侧多段线7个顶点
+ x% }4 b( Z/ f$ }* C
Dim basep(0 To 2) As Double '块基点
8 O3 y! n$ m1 J5 h! L' R- `
Dim playernumberpoint(0 To 2) As Double '块属性插入点
+ |6 C( U6 B9 m+ K# q
Dim mytxt As AcadTextStyle '定义mytxt变量为文本样式
1 b0 z, o3 m5 o- f( W
Dim blockRef As AcadBlockReference '定义块属性变量
/ Q$ N# ^1 S/ t
Dim Attr3 As Variant '插入块属性变量
3 j5 W ^$ o! D
7 r8 q- j: K" v* @% c- f
Set playerblock = ThisDrawing.Blocks.Add(basep, "球员") '定义一个"球员"的块
+ `9 S" \ c* U0 L7 a" q
2 N" r1 S7 U: w5 V% X3 p* B
arcc(0) = 0
; A/ i; y# W0 L' `8 X2 q
arcc(1) = 430
0 g) A& z: D% j8 O, w
Call playerblock.AddArc(arcc, 50, ThisDrawing.Utility.AngleToReal(180, 0), 0) '画弧并加入块中
& j9 P! z6 a7 R
6 }4 @& x/ c, \( c) H) ]6 Z7 j
pline(0) = 0
X2 Z1 G* i7 i! S$ @2 j* Z
pline(1) = 20
0 I+ ~: i* a+ U, b, |, V2 A# A0 P2 H
( v9 }, S$ V$ t0 \ Z/ x/ \
pline(3) = 100
2 I5 n, g& p# e' ?
pline(4) = 20
' M0 b! z% J5 w( x' ?
- d6 V2 y1 u. _5 e( {) i$ c
pline(6) = 100
& Z, w: j }# E( A8 v. Z
pline(7) = 250
2 w }0 B: x" N5 t
- p/ J5 W6 z3 D' z6 t* m
pline(9) = 125
' m+ K& i3 N, R& ?( { t
pline(10) = 207
. Z) y$ j$ {& W) c: X- G
/ Y# t( b+ P' z
pline(12) = 212
& |' {2 \$ c" u5 k4 R
pline(13) = 257
7 R" h3 x& y3 r; u5 p+ d
7 Q) U' z, {8 _8 h7 M, C& C) A$ s3 C
$ T n5 w3 k/ @% d8 f+ z$ o* n
pline(15) = 112
8 g6 z9 ~3 M: D* n$ w, w
pline(16) = 430
. n) S; y1 O7 {% k: ?( {% b
l0 l' d7 k0 c
" R$ {* i0 `' f% f3 a
pline(18) = 50
* m5 h6 }$ \4 x# N, k) ~
pline(19) = 430
[0 T& H( ^& C% H( K, \
6 }* I1 i1 V1 V& y. p
Set line1 = ThisDrawing.ModelSpace.AddPolyline(pline) '画队服右侧多段线
, m- N1 O# D+ b3 b
8 H3 W4 \8 q' ^3 T$ e. q
linep2(1) = 1 '镜像轴第二点位于Y轴上任一点
4 i& {( z* ?. s5 |; {1 z7 |
Set line2 = line1.Mirror(linep1, linep2) '镜像获得另一半多段线
- W! e. e9 a0 F% \7 ?
- h1 S4 q1 X' [5 P
Dim p(0 To 2) As Double '定义坐标变量
, Z4 S; O7 D! ~! O$ ^# C
Set mytxt = ThisDrawing.TextStyles.Add("mytxt") '添加mytxt样式
* h2 k1 S4 i! |, u) R& {+ \
mytxt.fontFile = "c:\windows\fonts\simfang.ttf" '设置字体文件为仿宋体
b- W3 U' R. ~5 w2 Q! G. k
ThisDrawing.ActiveTextStyle = mytxt '将当前文字样式设置为mytxt
9 ]+ V ^; y8 ]" c3 g/ p" z( y
* H6 F, l4 K: p3 {2 |/ m1 ^+ y
playernumberpoint(0) = 0 '块属性位置
# k0 u0 e; ~& V7 v3 x. J
playernumberpoint(1) = 200
7 z) l. N* v n. N, U& ^% `! |) L) Y8 @
Set attr1 = ThisDrawing.ModelSpace.AddAttribute(100, acAttributeModeNormal, "号码", playernumberpoint, "X", 0) '画块属性
+ g1 @, r! ^% V3 f, H! s
attr1.Alignment = 7 '居中
/ R5 Z7 o. c# W5 g a2 N7 n
attr1.TextAlignmentPoint = playernumberpoint '重定义对齐点
& i, x4 z- a4 T% @
Set attr2 = ThisDrawing.ModelSpace.AddAttribute(100, acAttributeModeNormal, "姓名", playernumberpoint, "???", 0) '画块属性
( `8 \ A7 H5 U* a, M6 q
attr2.Alignment = 7 '居中
3 \ `0 r" E0 j' F3 p$ u' ]6 \
+ u# r" O. A7 _) R8 I0 m9 r' G
: G) v1 I; e: q3 v1 l- G
Dim objCollection(0 To 3) As Object '创建选择集
3 ` C: H2 X' Q/ f: g* E$ J
Set objCollection(0) = line1 '线条1加入选择集
9 I5 k3 q6 l6 k) o) P: r
Set objCollection(1) = line2 '线条2加入选择集
! q/ v# L# ?- C2 F: }
Set objCollection(2) = attr1 '属性1加入选择集
# N. d5 ]% l) J
Set objCollection(3) = attr2 '属性2加入选择集
: s- U2 h; d0 H. q3 k, r
+ x: l; ]1 i n$ F9 m. U7 ]+ L
Call ThisDrawing.CopyObjects(objCollection, playerblock) '把选择集加入块中
) `9 t7 m4 L, s2 }( B' V" I9 j3 Z/ h" D
6 a8 s! }. P- ]" A/ {5 V: X
For Each element In objCollection '在选择集中进行循环
# q; k( F9 g' K; T' R- h& q
element.Delete '删除线条和属性(此操作并不影响已创建的块)
6 a: l( }# h1 f1 O6 r
Next
4 h) U7 k3 T; x! B/ _, n
! ^6 s6 R x0 m7 A5 V. B y
9 {. V# V$ |: `5 Y+ A# @" e
Set playerlay = ThisDrawing.Layers.Add("球员") '新建图层
6 o8 P3 w+ q+ A) G
playerlay.color = 2 '为黄色
2 y J# W$ t* f+ s* `3 g
ThisDrawing.ActiveLayer = playerlay '将当前图层设置为球员图层
0 `+ F* C a& P5 z0 Z( G! K
1 n M+ v# C$ _1 L2 b7 o! M8 t
Dim p1 As Variant '块插入点位置
- ~+ a8 o6 U# _( z
$ P4 ~& V# z- a; K: Y9 p
For i = 1 To 11 '插入块
: F# l! q# F' F! X/ F) P3 N0 E
pstring = CStr(i) & "号球员位置："
8 a4 a8 T8 b9 e5 L
p1 = ThisDrawing.Utility.GetPoint(, pstring) '点选球员位置坐标
* x, ?* o5 K# X8 H0 G) k$ |
nstring = ThisDrawing.Utility.GetString(30, "球员姓名：")
% H% O r8 Y; @" s$ i! J& y
Set blockRef = ThisDrawing.ModelSpace.InsertBlock(p1, "球员", 1, 1, 1, 0) '插入块
q+ l# n5 r! ^0 ^0 c. ?4 U
Attr3 = blockRef.GetAttributes '获取块属性
8 \0 q# b0 l0 J# y7 J
Attr3(0).TextString = CStr(i) '赋值球员号码
3 `1 F; C$ u% ?6 V
Attr3(1).TextString = nstring '赋值球员姓名
, @1 Q; y! Z2 N2 [
Next
g- y5 @ b8 h& ~" w/ G
' M: w$ f. `! N
End Sub
作者:
ytcadtools
时间:
2008-10-30 11:26
太好了，本人正在研究这方面的程序，借鉴一下
作者:
licumu
时间:
2009-2-12 11:28
感谢楼主的分享，在CAD2009中尝试一下，有问题来咨询楼主您。
作者:
林一飞
时间:
2010-1-18 23:04
正在找这方面的资料呀……
作者:
cqc2007
时间:
2010-5-25 13:42
非常受用,谢谢楼主
作者:
arena
时间:
2010-8-31 17:16
非常詳細的VBA教學,對初學者是一大幫助.謝謝!
作者:
baby008
时间:
2010-11-30 17:50
资料很好的
欢迎光临 三维网 (http://www.3dportal.cn/discuz/)
Powered by Discuz! X3.4