Autocad vbA 初级教程(13) 块操作

更新时间：2023-10-09 01:39:01 阅读量：综合文库文档下载

说明：文章内容仅供预览，部分内容可能不全。下载后的文档，内容与下面显示的完全一致。下载之前请确认下面内容是否您想要的，是否完整无缺。

autocad推荐度：
相关推荐

定义块方法：

Set blocksobj=ThisDrawing.Blocks.Add(基点, 块名)把选择集加入块中的方法：

三维,cad,机械技术汽车,catia,pro/e,ug,inventor,solidedge,solidwors,caxa,时空镇江, ^' z P# X7 E* K1 www.3dportal.cn3 g- P8 i3 S# A c( @

ThisDrawing.CopyObjects(选择集,块) 插入块方法：

三维,cad,机械技术汽车,catia,pro/e,ug,inventor,solidedge,solidwors,caxa,时空镇江6 i& ~4 E. C# M0 y7 H

ThisDrawing.ModelSpace.InsertBlock(插入点,块名, X轴比例,Y轴比例,Z轴比例, 旋转角度) 画块属性方法：

三维网技术论坛) W, P; l+ `2 {* S$ v7 h

ThisDrawing.ModelSpace.AddAttribute(文字高度,模式,提示字符, 插入点, 显示字符,默认值)一共有五种模式，在输入时会有提示，其中最常用的是“acAttributeModeNormal”普通模式编程思路： 1．定义一个空块

2．在块中画一段弧（球服衣领）3．画多段线，镜像画出球衣

三维,cad,机械技术汽车,catia,pro/e,ug,inventor,solidedge,solidwors,caxa,时空镇江2 r( W! y$ ^; ]4 Y

三维,cad,机械技术汽车,catia,pro/e,ug,inventor,solidedge,solidworks,caxa,时空镇江3 B- B& D! Y$ W- o P( i

4．画块属性，由于块属性默认的对齐方式是左对齐，而球员号码应该居中，所以必须把块的对齐属性改为居中。但是当这个属性更改时块属性对齐点会自动归零，所以不得不再次更改对齐点属性5．把多段线和属性复制到块中 6．提示用户点选球员位置和姓名

三维网技术论坛* d0 j* A! j, F) s8 d

www.3dportal.cn1 K' @9 b; O$ s7 d( Y

7．插入块，修改球衣号码属性、球员姓名属性

三维,cad,机械技术汽车,catia,pro/e,ug,inventor,solidedge,solidwors,caxa,时空镇江0 g$ c4 Y% ?$ ?2 ?! ]+ Y+ T; R) B% N

三维网技术论坛* v$ H& `- C, v: D$ q8 [ [. T

以下是源码，附有详细的注释，如果有疑问，建议用变量跟踪法研究一下。Sub team()

Dim playerlay As AcadLayer '定义球员图层Dim playerblock As AcadBlock '定义块变量Dim arcc(0 To 2) As Double '圆弧圆心 Dim linep1(0 To 2) As Double '线条端点1Dim linep2(0 To 2) As Double '线条端点2

www.3dportal.cn( ^3 t9 a. t/ c( a. d) C\

www.3dportal.cn, C. T; d( `, q! E

www.3dportal.cn$ D9 p2 p- [6 S$ [2 n/ A8 r9 p b

三维|cad|机械汽车技术|catia|pro/e|ug|inventor|solidedge|solidwors|caxa6 I7 f I- S! { }* X8 f* s

三维网技术论坛! x# u/ a& C$ j* t

Dim pline(0 To 20) As Double '定义队服右侧多段线7个顶点Dim basep(0 To 2) As Double '块基点

- L. ]0 H( M0 R; {

Dim playernumberpoint(0 To 2) As Double '块属性插入点 Dim mytxt As AcadTextStyle '定义mytxt变量为文本样式 Dim blockRef As AcadBlockReference '定义块属性变量Dim Attr3 As Variant '插入块属性变量

三维,cad,机械技术汽车,catia,pro/e,ug,inventor,solidedge,solidwors,caxa,时空镇江# S* z& D$ m2 G& [' g

三维网技术论坛4 P( A6 A T, j1 o! G

Set playerblock = ThisDrawing.Blocks.Add(basep, \球员\定义一个\球员\的块

arcc(0) = 0 arcc(1) = 430

_2 q% u0 j a f# D2 x; f& y

+ {3 s2 s, T; ~0 F: p& o

Call playerblock.AddArc(arcc, 50, ThisDrawing.Utility.AngleToReal(180, 0), 0) '画弧并加入块中

pline(0) = 0

三维网技术论坛9 g' C+ Q8 F\

pline(1) = 20

pline(3) = 100pline(4) = 20

pline(6) = 100

三维网技术论坛+ k: o8 ]* g* j) Q$ n8 g

www.3dportal.cn! o. x4 F5 A' b1 . r( _4 b/ |

pline(7) = 250

www.3dportal.cn( ~6 u. N2 b% M) V

三维网技术论坛7 _' ^8 N' [9 j) A

pline(9) = 125

pline(10) = 207

三维网技术论坛0 a& z n; ]6 R1 Y. V+ o

www.3dportal.cn5 ~4 K\: e( I9 }$ ~

pline(12) = 212

pline(13) = 257

三维网技术论坛' U! ]! v( m+ @' U; L% b

pline(15) = 112 pline(16) = 430

pline(18) = 50 pline(19) = 430

www.3dportal.cn# b( b1 n* y: I1 Y$ v! Q

三维|cad|机械汽车技术|catia|pro/e|ug|inventor|solidedge|solidwors|caxa6 8 T$ u/ w! h3 v3 ?7 k- 三维网技术论坛$ {/ Q9 x0 m8 J( Q, Y0 A: |

Set line1 = ThisDrawing.ModelSpace.AddPolyline(pline) '画队服右侧多段线

+ e9 B- z\\i9 _

三维网技术论坛* t* v7 J- ?9 G9 T

linep2(1) = 1 '镜像轴第二点位于Y轴上任一点

Set line2 = line1.Mirror(linep1, linep2) '镜像获得另一半多段线

Dim p(0 To 2) As Double '定义坐标变量

三维网技术论坛0 h: b7 w6 ?+ R+ l& H. Z0 m2 O# i

三维网技术论坛2 K- S# N: U. P' _7 Y4 I: V1 s: T) T: R

Set mytxt = ThisDrawing.TextStyles.Add(\添加mytxt样式

mytxt.fontFile = \设置字体文件为仿宋体

ThisDrawing.ActiveTextStyle = mytxt '将当前文字样式设置为mytxt

playernumberpoint(0) = 0 '块属性位置playernumberpoint(1) = 200

三维网技术论坛6 t' H0 q3 \\) P6 s. {4 O

三维,cad,机械技术汽车,catia,pro/e,ug,inventor,solidedge,solidwors,caxa,时空镇江9 E. ^& E& z. S, q2 z8 U

Set attr1 = ThisDrawing.ModelSpace.AddAttribute(100, acAttributeModeNormal, \号码\playernumberpoint, \画块属性

attr1.Alignment = 7 '居中

attr1.TextAlignmentPoint = playernumberpoint '重定义对齐点

Set attr2 = ThisDrawing.ModelSpace.AddAttribute(100, acAttributeModeNormal, \姓名\playernumberpoint, \画块属性 attr2.Alignment = 7 '居中

三维网技术论坛7 F$ r6 X1 N4 g h* ]- u2 V

Dim objCollection(0 To 3) As Object '创建选择集 Set objCollection(0) = line1 '线条1加入选择集

三维网技术论坛# ^# C6 ^\L: U2 h: |! p

Set objCollection(1) = line2 '线条2加入选择集 Set objCollection(2) = attr1 '属性1加入选择集Set objCollection(3) = attr2 '属性2加入选择集

Call ThisDrawing.CopyObjects(objCollection, playerblock) '把选择集加入块中

For Each element In objCollection '在选择集中进行循环

www.3dportal.cn H7 C4 [6 s- ^$ H G) L: {. V0 V

www.3dportal.cn# I! d5 s' I$ Q4 B

element.Delete '删除线条和属性(此操作并不影响已创建的块)Next

Set playerlay = ThisDrawing.Layers.Add(\球员\新建图层 playerlay.color = 2 '为黄色

三维,cad,机械技术汽车,catia,pro/e,ug,inventor,solidedge,solidworks,caxa,时空镇江: ~% T p8 X7 u5 www.3dportal.cn( o# A& ], a+ }4 ?

; O2 _& H' F0 Z# L- z L

ThisDrawing.ActiveLayer = playerlay '将当前图层设置为球员图层

Dim p1 As Variant '块插入点位置

0 _7 Y) d9 ?+ m& X

For i = 1 To 11 '插入块

pstring = CStr(i) & \号球员位置：\

三维,cad,机械技术汽车,catia,pro/e,ug,inventor,solidedge,solidwors,caxa,时空镇江- T; i. _1 r\F/ {1 Y

三维,cad,机械技术汽车,catia,pro/e,ug,inventor,solidedge,solidwors,caxa,时空镇江6 c s6 v& C% i4 p1 = ThisDrawing.Utility.GetPoint(, pstring) '点选球员位置坐标 nstring = ThisDrawing.Utility.GetString(30, \球员姓名：\

三维网技术论坛% m5 v% G1 D7 J' C- m- e

Set blockRef = ThisDrawing.ModelSpace.InsertBlock(p1, \球员\插入块 Attr3 = blockRef.GetAttributes '获取块属性 Attr3(0).TextString = CStr(i) '赋值球员号码

www.3dportal.cn& i1 } }/ A1 W8 s7 T: A

三维网技术论坛, E* D* H8 C* r4 u$ l/ }\

Attr3(1).TextString = nstring '赋值球员姓名 Next

- s' W2 @1 N4 h( M8 L

三维,cad,机械技术汽车,catia,pro/e,ug,inventor,solidedge,solidwors,caxa,时空镇江0 d2 j% P2 U$ N9 f+ ~6 _

End Sub

本文来源：https://www.bwwdw.com/article/b2cf.html

相关文章：