Autocad VBA初级教程 （强烈推荐）

pengyg1204

好东东啊！先COPY下来再看，呵呵！

wangpiwujing

谢谢,我是菜鸟不是很懂,感觉很好 啊!

yhfsmu

先收藏起来，慢慢看看，谢谢了

设计从零

支持楼主！！！
3 T, c/ z4 F5 }) h- X) h; s1 j" g！

hellmen

斑竹,还有写好的教程吗?

tianyunxuan

简单地讲，参数化设计就是根据参数进行精确绘图，绘图所需要的参数也可以由用户手工输入。真正的参数化设计往往需要数据库操作，为了简化程序，把数据库部分放在以后的课程中详细讲解。

7 q9 C% i/ V  a7 h+ C( N5 q- [    本课的例程是画一个标准足球场。足球场长度90～120米，宽度45～90米，而红色标注的尺寸是程序默认的，绿色标注固定不变。



6 S1 ?- ?* v& D) m# ^  v' B
Sub court()
3 k- H8 t+ s4 d& b, P' r' h4 a4 i( j0 C1 fDim courtlay As AcadLayer '定义球场图层
Dim ent As AcadEntity '镜像对象
  l+ O- ^2 G' {9 k! Q( D" vDim linep1(0 To 2) As Double '线条端点1
Dim linep2(0 To 2) As Double '线条端点2
Dim linep3(0 To 2) As Double '罚球弧端点1
7 u" d+ i9 e  H% x+ mDim linep4(0 To 2) As Double '罚球弧端点2
Dim centerp As Variant '中心坐标
xjq = 11000 '小禁区尺寸
, m+ u/ \% K$ I' X+ k$ Wdjq = 33000 '大禁区尺寸
7 V0 W6 _* u- n5 ^7 W- v2 Qfqd = 11000 '罚球点位置
fqr = 9150 '罚球弧半径
fqh = 14634.98 '罚球弧弦长
jqqr = 1000 '角球区半径
zqr = 9150 '中圈半径
* T  l# J. W; u5 X+ {& Y  r
( \7 P: A$ e) KOn Error Resume Next
chang = ThisDrawing.Utility.GetReal("长度(90000～120000)<105000>")
If Err.Number <> 0 Then '用户输入的不是有效数字
1 K' t8 w4 k: J7 j  chang = 105000
' G1 ]$ w& F2 c/ Y# r2 d  Err.Clear '清除错误
End If
& z; u8 y# p7 O/ W0 f- @# V4 Z: Hkuan = ThisDrawing.Utility.GetReal("宽度(45000～90000)<68000>")
If Err.Number <> 0 Then
  kuan = 68000
6 ]6 C- i+ g# m3 p+ l# \) Z1 V& |; b$ EEnd If

, e+ S6 ?& m7 a* scenterp = ThisDrawing.Utility.GetPoint(, "定位球场中心:")
& P+ V9 z" f9 D$ K1 B
Set courtlay = ThisDrawing.Layers.Add("足球场") '设置图层
% W+ ]4 V$ O4 L5 l6 FThisDrawing.ActiveLayer = courtlay '把当前图层设为足球场图层

& C4 g+ b5 a% n3 z1 X'画小禁区
linep1(0) = centerp(0) + chang / 2
linep1(1) = centerp(1) + xjq / 2
9 n4 d1 V& e0 N+ c# F# flinep2(0) = centerp(0) + chang / 2 - xjq / 2
linep2(1) = centerp(1) - xjq / 2
2 `, H1 B% Q6 P1 `2 v5 w3 ~Call drawbox(linep1, linep2) '调用画矩形子程序

! }6 [( Y; m5 S9 u) \$ \
& d: o$ W* e! ?: V' M
'画大禁区
linep1(0) = centerp(0) + chang / 2
linep1(1) = centerp(1) + djq / 2
linep2(0) = centerp(0) + chang / 2 - djq / 2
  X7 p& m& j" H! c1 {linep2(1) = centerp(1) - djq / 2
Call drawbox(linep1, linep2)
( S& u0 V8 T4 x7 b

' 画罚球点
* p- [1 l! ^( d+ ]linep1(0) = centerp(0) + chang / 2 - fqd
0 C9 C1 I. m3 U1 J/ l, W( S  r4 `/ Z, Dlinep1(1) = centerp(1)
Call ThisDrawing.ModelSpace.AddPoint(linep1)
/ ~1 W/ ]) H) V& V& [+ l1 r'ThisDrawing.SetVariable "PDMODE", 32 '点样式
ThisDrawing.SetVariable "PDSIZE", 30 '点的尺寸
. D2 m* n) l( {* H  z
( q4 f5 L- L9 G- I( n, B" f8 w3 g'画罚球弧，罚球弧圆心就是罚球点linep1
6 H5 @6 M- \0 L3 S6 y2 D8 tlinep3(0) = centerp(0) + chang / 2 - djq / 2
# T3 ?. n. T) b5 D9 o# Q  slinep3(1) = centerp(1) + fqh / 2
$ A( i/ d. m2 Olinep4(0) = linep3(0) '两个端点的x轴相同
- j  U' _- ?& @  q- N+ W  ulinep4(1) = centerp(1) - fqh / 2
ang1 = ThisDrawing.Utility.AngleFromXAxis(linep1, linep3) '计算角度
9 W8 u0 j1 I% dang2 = ThisDrawing.Utility.AngleFromXAxis(linep1, linep4)
Call ThisDrawing.ModelSpace.AddArc(linep1, zqr, ang1, ang2) '画弧
. \4 E' G" N! h$ {& I$ \
6 Q/ a1 ~# E7 S9 x
'角球弧
8 u/ [1 I8 U- Z2 Z/ L; n6 aang1 = ThisDrawing.Utility.AngleToReal(90, 0) '角度转换为弧度
. r+ E1 ?7 }% @  Q: A) P% Tang2 = ThisDrawing.Utility.AngleToReal(180, 0)
3 ]8 A  {5 z4 Qlinep1(0) = centerp(0) + chang / 2 '角球弧圆心
linep1(1) = centerp(1) - kuan / 2
Call ThisDrawing.ModelSpace.AddArc(linep1, jqqr, ang1, ang2) '画弧
# t9 m" c( P( ~+ o( ^7 @
' c4 V) r+ [* l- i% }# eang1 = ThisDrawing.Utility.AngleToReal(270, 0)
) p+ v6 l& E  ]) glinep1(1) = centerp(1) + kuan / 2
( T5 v6 G& y5 j7 wCall ThisDrawing.ModelSpace.AddArc(linep1, jqqr, ang2, ang1)
' f7 E+ _& R4 @4 |/ @5 d9 I
& s; R/ D+ O+ z5 `# m, ^
- V! y& r" y: G& [! ?' t
5 A, l4 l, q# ?* n4 y* H'镜像轴
/ h. k: U% O' S3 Z& f0 z. L' flinep1(0) = centerp(0)
linep1(1) = centerp(1) - kuan / 2
; ]; m3 b, D, \, J. o  k2 flinep2(0) = centerp(0)
( P6 |" g8 _: R! [8 `. Hlinep2(1) = centerp(1) + kuan / 2

'镜像
' m; D. h  d8 Q+ aFor Each ent In ThisDrawing.ModelSpace '所有模型空间的对象进行一次循环
0 ^0 M) {: z( o) i( L& b5 p  If ent.Layer = "足球场" Then '对象在"足球场"图层中
    ent.Mirror linep1, linep2 '镜像
  End If
# z2 x# D. K  a4 k' H/ {9 e- PNext ent
9 v2 l# c# t- ]3 B1 Y4 N" k
'画中线
Call ThisDrawing.ModelSpace.AddLine(linep1, linep2)

: y9 }5 K5 B4 X9 d'画中圈
: Q; ?9 B/ F$ I. @, b" a4 J! yCall ThisDrawing.ModelSpace.AddCircle(centerp, zqr)

'画外框
linep1(0) = centerp(0) - chang / 2
linep1(1) = centerp(1) - kuan / 2
linep2(0) = centerp(0) + chang / 2
& Z( U- v3 b3 [8 s/ Q2 plinep2(1) = centerp(1) + kuan / 2
7 t! Q7 N" C& g3 `: H" x/ A' g$ wCall drawbox(linep1, linep2)
) U2 p0 ]- b& D. @6 C6 n  t
2 c2 s  l3 k" F  S0 nZoomExtents '显示整个图形

0 W2 h  R: C3 E, x; K, IEnd Sub
* s% T5 V& |: u2 y" L7 I
Private Sub drawbox(p1, p2) '根据对角线坐标画矩形的子程序
) P) p! F8 |- U* c4 c. m7 EDim boxp(0 To 14) As Double
7 k  |) j% j% L3 Z) G
& R3 l3 K, b* {" s8 [& S; Nboxp(0) = p1(0)
* d3 W' o- `3 H2 Qboxp(1) = p1(1)

boxp(3) = p1(0)
boxp(4) = p2(1)

  V* t5 m9 \4 A. V8 G3 Cboxp(6) = p2(0)
7 z# e" i, @. H1 E; Aboxp(7) = p2(1)

0 {+ h7 J* L6 s2 ~* z9 g5 C, L# Hboxp(9) = p2(0)
boxp(10) = p1(1)

boxp(12) = p1(0)
boxp(13) = p1(1)

Call ThisDrawing.ModelSpace.AddPolyline(boxp)
5 e$ `8 K- D* j* L
End Sub
) G% {/ U, O1 F& m  `' E4 L/ I
5 X- n% E# K% G% ?


下面开始分析源码：
, l+ P) e. ~9 D/ F/ X; F
1 y" X9 ]1 }; [5 q, ~On Error Resume Next
( b, k, g6 M* }* [  s3 ]chang = ThisDrawing.Utility.GetReal("长度(90～120)<10500>")
' ~7 F0 a/ \6 g  m7 J* EIf Err.Number <> 0 Then '用户输入的不是有效数字
chang = 10500
. X: K/ H, c6 ~2 S: k3 k' ^" mErr.Clear '清除错误
" {6 ^, r9 D& v6 a' pEnd If

    这段代码的作用是要求用户输入一个足球场长度的数字，由于getreal只能输入数字，如果输入其他字符程序就会报错，所以先要用去掉错误提示：On Error Resume Next，虽然错误不再提示，但是出错代码会err.number改变，有兴趣的读者可以用变量跟踪的方法看看这个代码的数值。您只要记住，如果这个数字不是0，那么就是有错了，这时就可以把长度定为默认值，然后用Err.Clear语句把错误代码清零。
2 P0 @9 Z& ^* T
8 v# \& x' q9 G, F. O
    在画小禁区的最后一行这样写：Call drawbox(linep1, linep2)
/ T! \! S9 @' S) c" A' I4 I
% d0 _- \/ x  w1 d    Drawbox并不是vba提供的方法，它是一个带参数的子程序。由于画足球场要画好几次矩形，
而vba没有提供一个现成的画矩形方法，如果每次都用一长串代码画矩形是很麻烦的，所以需要把这些麻烦的代码写到一个子程序中，在需要时只有写一条调用语句就行了。这个子程序最后几行，从“Private Sub drawbox(p1, p2) ”开始，到end sub结束，p1,p2是参数，调用时也必须写两个参数：linep1、linep2。

) _5 t' ?+ p6 w: U* n
5 `' j: k! E9 K( V. _ang1 = ThisDrawing.Utility.AngleFromXAxis(linep1, linep3) '计算角度
% A: z0 m" P# E. d: cang2 = ThisDrawing.Utility.AngleFromXAxis(linep1, linep4)
Call ThisDrawing.ModelSpace.AddArc(linep1, zqr, ang1, ang2) '画弧

4 y5 C2 w* d: C4 c/ S7 o& B, y    画圆用addarc方法，需要4个参数：圆心、半径、起始角度、结束角度。AngleFromXAxis用于计算角度，其参数需要两个点坐标

* ^9 `; B2 C: G7 e: g) w4 e2 T! E下面看镜像操作：
For Each ent In ThisDrawing.ModelSpace '所有模型空间的对象进行一次循环
  If ent.Layer = "足球场" Then '对象在"足球场"图层中
7 \$ c0 j3 ]: O    ent.Mirror linep1, linep2 '镜像
  End If
) d1 A8 K* Y/ NNext ent
$ ]- {' v; E! t3 k5 t0 W$ ~0 \
    本例只对“足球场”图层中的对象进行镜像，所以要对全部对象进行循环，判断对象的图层属性，只有位于“足球场”图层中的对象才作镜像。


- `9 x2 I9 i- _3 Z/ h本课思考题：
& v6 i$ L1 _5 P
1、对本课的例程进行修改，当用户输入长、宽不在规定的范围时要求用户重新输入

2、设计一张简单的平面图，用户输入2个参数，其他尺寸写进程序中
# i0 s6 t4 ~( V% J9 {0 k! N
[ 本帖最后由 tianyunxuan 于 2007-5-26 20:10 编辑 ]

tianyunxuan

定义块方法：

Set blocksobj=ThisDrawing.Blocks.Add(基点, 块名)
把选择集加入块中的方法：
ThisDrawing.CopyObjects(选择集,块)
插入块方法：
ThisDrawing.ModelSpace.InsertBlock(插入点,块名, X轴比例,Y轴比例,Z轴比例, 旋转角度)
: e6 m* ?9 h' z9 G画块属性方法：
ThisDrawing.ModelSpace.AddAttribute(文字高度,模式,提示字符, 插入点, 显示字符,默认值)
一共有五种模式，在输入时会有提示，其中最常用的是“acAttributeModeNormal”普通模式
6 d% l6 e5 H# t, K: c2 h  n8 r* J

# Q* I6 `7 F: N. M3 y+ r& O0 A下面的例题是利用属性块画足球场的阵型图。
程序画出一个球员块，然后把块写到用户指定位置，球员号码由程序自动递增，把球员姓名改为用户输入值。画足球场请参阅上一课内容。
! l- Q3 X1 z* q$ m

4 _2 _4 T$ T$ i4 L/ Z5 H2 k- R

/ }- Y/ O# B" h! d

编程思路：
$ Y, |4 v0 d" Y! p1．定义一个空块
( X" u6 H7 o$ n- ]2．在块中画一段弧（球服衣领）
6 R# Z, B+ l3 Q3．画多段线，镜像画出球衣
0 e" [3 {3 q) @# m# _6 c4．画块属性，由于块属性默认的对齐方式是左对齐，而球员号码应该居中，所以必须把块的对齐属性改为居中。但是当这个属性更改时块属性对齐点会自动归零，所以不得不再次更改对齐点属性
5．把多段线和属性复制到块中
6．提示用户点选球员位置和姓名
7．插入块，修改球衣号码属性、球员姓名属性
2 x( Z7 |$ p/ x# l
以下是源码，附有详细的注释，如果有疑问，建议用变量跟踪法研究一下。
+ G3 H0 D0 _: Y, h% s; |Sub team()
* K2 ]& v" G# \7 aDim playerlay As AcadLayer '定义球员图层
5 i3 l; a: \! oDim playerblock As AcadBlock '定义块变量
$ o* N3 L. Z! s: l" ^. hDim arcc(0 To 2) As Double '圆弧圆心
Dim linep1(0 To 2) As Double '线条端点1
- q( E9 J1 Z7 A5 h, m7 T5 M4 ADim linep2(0 To 2) As Double '线条端点2
. e5 k; r' a2 Z% [Dim pline(0 To 20) As Double '定义队服右侧多段线7个顶点
Dim basep(0 To 2) As Double '块基点
) X- R1 k8 Q% W" jDim playernumberpoint(0 To 2) As Double '块属性插入点
4 W  y) K; p3 e) n7 bDim mytxt As AcadTextStyle '定义mytxt变量为文本样式
Dim blockRef As AcadBlockReference '定义块属性变量
Dim Attr3 As Variant '插入块属性变量
8 o+ e' U& i1 I( S3 [' x+ D
% [1 P* v5 E3 Y4 iSet playerblock = ThisDrawing.Blocks.Add(basep, "球员") '定义一个"球员"的块
4 G6 u2 W& t/ ~$ m
# w: N* y( q2 ]" f2 D9 |arcc(0) = 0
arcc(1) = 430
Call playerblock.AddArc(arcc, 50, ThisDrawing.Utility.AngleToReal(180, 0), 0) '画弧并加入块中
- b* |; y* w" X) @/ I7 |% A9 }2 I/ j
pline(0) = 0
0 i1 a6 U) w% cpline(1) = 20

9 ^+ H! f0 W$ _8 _pline(3) = 100
! ~2 o+ \' {9 ]' qpline(4) = 20
/ R: [6 h/ d" U- J$ W
, o0 n9 L9 `+ x+ z0 Apline(6) = 100
pline(7) = 250

5 T# B/ d$ _$ y3 W" [9 ^pline(9) = 125
3 C% ^  O) K; u; @6 dpline(10) = 207
9 z5 v9 F1 n- e- E' y% {
pline(12) = 212
pline(13) = 257
3 j  \: Y+ i% O$ c% E  B- `
) F- v4 p: p0 c" ^2 V; ?' `( r( j$ b8 R
pline(15) = 112
% n: n6 T9 e1 @4 s! Fpline(16) = 430

2 i4 A/ |9 A9 f8 i. B! E) u
pline(18) = 50
; \: e2 X7 R* ]" H4 A4 Ipline(19) = 430

$ r$ P8 \. ^3 L( d  bSet line1 = ThisDrawing.ModelSpace.AddPolyline(pline) '画队服右侧多段线
: x; S- Y% ^- P# f
linep2(1) = 1 '镜像轴第二点位于Y轴上任一点
Set line2 = line1.Mirror(linep1, linep2) '镜像获得另一半多段线
$ |: O4 \* G, y+ m# w  r" {- V  r- T
Dim p(0 To 2) As Double '定义坐标变量
: C  M& `3 Z" j7 \! n! bSet mytxt = ThisDrawing.TextStyles.Add("mytxt") '添加mytxt样式
: q0 a- t+ V% N3 @( I5 P# y& Tmytxt.fontFile = "c:\windows\fonts\simfang.ttf" '设置字体文件为仿宋体
ThisDrawing.ActiveTextStyle = mytxt '将当前文字样式设置为mytxt

playernumberpoint(0) = 0 '块属性位置
4 T3 A/ `$ {" h5 Splayernumberpoint(1) = 200
* V* X) W8 r) Z( }# m/ BSet attr1 = ThisDrawing.ModelSpace.AddAttribute(100, acAttributeModeNormal, "号码", playernumberpoint, "X", 0) '画块属性
. n4 w: s4 l- ]# x) s$ U9 Eattr1.Alignment = 7 '居中
attr1.TextAlignmentPoint = playernumberpoint '重定义对齐点
% n0 q+ T6 ^' t! N" f0 u4 F" RSet attr2 = ThisDrawing.ModelSpace.AddAttribute(100, acAttributeModeNormal, "姓名", playernumberpoint, "???", 0) '画块属性
. i0 ?1 v. k9 oattr2.Alignment = 7 '居中


Dim objCollection(0 To 3) As Object '创建选择集
7 U! E- M# ]) n. \' XSet objCollection(0) = line1 '线条1加入选择集
Set objCollection(1) = line2 '线条2加入选择集
9 E! J) X5 x& s; {4 H2 NSet objCollection(2) = attr1 '属性1加入选择集
Set objCollection(3) = attr2 '属性2加入选择集
. N- d. e( x$ Z$ u2 @8 K1 l
8 l  B' t; c/ M. m  @5 W9 x" SCall ThisDrawing.CopyObjects(objCollection, playerblock) '把选择集加入块中

' U0 d( u1 }% q6 [For Each element In objCollection '在选择集中进行循环
1 L7 M9 h$ V* `5 v& U  element.Delete '删除线条和属性(此操作并不影响已创建的块)
5 s. {/ g7 j- E( n3 h. ENext
0 r1 y/ U6 c2 l2 q

Set playerlay = ThisDrawing.Layers.Add("球员") '新建图层
; J+ E, L, i/ {playerlay.color = 2 '为黄色
ThisDrawing.ActiveLayer = playerlay '将当前图层设置为球员图层

Dim p1 As Variant '块插入点位置

For i = 1 To 11 '插入块
  pstring = CStr(i) & "号球员位置："
) q, v( _2 c5 p8 b, m; Q  p1 = ThisDrawing.Utility.GetPoint(, pstring) '点选球员位置坐标
$ V! l. r; w% |: d% M0 ]2 g  nstring = ThisDrawing.Utility.GetString(30, "球员姓名：")
4 t, k" D1 K. i, v* u  Set blockRef = ThisDrawing.ModelSpace.InsertBlock(p1, "球员", 1, 1, 1, 0) '插入块
  Attr3 = blockRef.GetAttributes '获取块属性
- m, h4 o, n" Q1 L' E5 E' v  Attr3(0).TextString = CStr(i) '赋值球员号码
  Attr3(1).TextString = nstring '赋值球员姓名
Next

End Sub

本课思考题：
& o! g3 k* a: O  C" z, P1、在本课例程的最后一段增加出错陷阱代码，当用户输入非正常数值时退出程序
2、画一个简易路灯块，用属性块做为路灯编号，由用户点选路灯位置，程序画路灯时自动为路灯编号

trinco

很有帮助！谢谢lz

cgc

终于看好了，写得很不错， 连我从来不写程序的人都能看得懂了

好好学习，感觉函数 方面还有很多的东西不是很懂
' o2 }/ s8 O! x# }3 G; k0 j8 \- s
0 v# d6 x- h4 z/ Z- V8 J  t有函数库可以查阅么？
; y4 s# w: W8 j, c7 ^0 a( G1 V
买书也行

nebs

偶是菜鸟 还看不懂 还是顶你一下  辛苦啦

lianghn1986

头痛呀~~~~~~~~~~~~

pianpi111

auto cad vba第一次听说
学学

nebs

顶！！ 学习中.....

sod11791

太难了，能学会吗？

kyokula

学ＶＢ是不是必须要懂Ｃ语言？