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

pengyg1204

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

wangpiwujing

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

yhfsmu

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

设计从零

支持楼主！！！
% O  R/ X2 E2 H0 N8 `！

hellmen

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

tianyunxuan

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

# E4 [, k6 a! y; R( P5 F    本课的例程是画一个标准足球场。足球场长度90～120米，宽度45～90米，而红色标注的尺寸是程序默认的，绿色标注固定不变。



4 C( |- D3 h8 w* M
+ f0 G2 J+ p* ?' |Sub court()
Dim courtlay As AcadLayer '定义球场图层
$ g3 e  V9 N  ~7 eDim ent As AcadEntity '镜像对象
Dim linep1(0 To 2) As Double '线条端点1
Dim linep2(0 To 2) As Double '线条端点2
Dim linep3(0 To 2) As Double '罚球弧端点1
% N7 H" t. E3 K$ YDim linep4(0 To 2) As Double '罚球弧端点2
Dim centerp As Variant '中心坐标
' [, `5 V  _$ o/ _5 L# ^- Dxjq = 11000 '小禁区尺寸
2 z( @' s/ m: s3 k, odjq = 33000 '大禁区尺寸
3 G' `; z) [% W2 W* ?) jfqd = 11000 '罚球点位置
fqr = 9150 '罚球弧半径
fqh = 14634.98 '罚球弧弦长
! v! p4 s4 V; `1 e2 a4 Yjqqr = 1000 '角球区半径
0 ?) f& L$ S0 B5 t' [zqr = 9150 '中圈半径

2 Z  O3 y" ?  \( t+ x8 eOn Error Resume Next
7 {9 z: s' E/ a9 dchang = ThisDrawing.Utility.GetReal("长度(90000～120000)<105000>")
1 v7 o* G1 q3 s: c0 fIf Err.Number <> 0 Then '用户输入的不是有效数字
  chang = 105000
  Err.Clear '清除错误
End If
kuan = ThisDrawing.Utility.GetReal("宽度(45000～90000)<68000>")
4 f9 R6 m8 w& Y; _If Err.Number <> 0 Then
% _4 p: s8 S9 t) Z6 V3 f) N& j, @  kuan = 68000
7 r8 W/ T: a& z- s4 oEnd If

centerp = ThisDrawing.Utility.GetPoint(, "定位球场中心:")

Set courtlay = ThisDrawing.Layers.Add("足球场") '设置图层
ThisDrawing.ActiveLayer = courtlay '把当前图层设为足球场图层

'画小禁区
linep1(0) = centerp(0) + chang / 2
9 Q1 a- K: S  A! M7 t. v, x0 U, q$ Blinep1(1) = centerp(1) + xjq / 2
% L: w5 ?1 S; O2 Elinep2(0) = centerp(0) + chang / 2 - xjq / 2
9 H: y& `2 N. O8 Z+ B6 vlinep2(1) = centerp(1) - xjq / 2
Call drawbox(linep1, linep2) '调用画矩形子程序
5 J9 m- f4 ^, {8 E' b
; q3 a- v1 f% \8 F( i4 h6 g% ^+ L

'画大禁区
linep1(0) = centerp(0) + chang / 2
linep1(1) = centerp(1) + djq / 2
& [, P' @6 K/ T' j5 f. F4 _6 A* Ylinep2(0) = centerp(0) + chang / 2 - djq / 2
linep2(1) = centerp(1) - djq / 2
7 f7 y! V9 s' c: c1 oCall drawbox(linep1, linep2)
) X& q2 a  W4 {" g. o

' 画罚球点
( U, l0 U% C  l, w. _2 Zlinep1(0) = centerp(0) + chang / 2 - fqd
) i2 l/ c9 C4 |; J3 a" k: p( plinep1(1) = centerp(1)
Call ThisDrawing.ModelSpace.AddPoint(linep1)
+ K+ G2 S8 M) x5 [3 |; q'ThisDrawing.SetVariable "PDMODE", 32 '点样式
ThisDrawing.SetVariable "PDSIZE", 30 '点的尺寸

" T; c8 w. N! E' d8 o, x'画罚球弧，罚球弧圆心就是罚球点linep1
linep3(0) = centerp(0) + chang / 2 - djq / 2
linep3(1) = centerp(1) + fqh / 2
2 @& g- G7 E. n1 Wlinep4(0) = linep3(0) '两个端点的x轴相同
linep4(1) = centerp(1) - fqh / 2
ang1 = ThisDrawing.Utility.AngleFromXAxis(linep1, linep3) '计算角度
ang2 = ThisDrawing.Utility.AngleFromXAxis(linep1, linep4)
) k, v4 D5 `; P' A% x1 H4 B3 oCall ThisDrawing.ModelSpace.AddArc(linep1, zqr, ang1, ang2) '画弧
% Y2 G$ H9 E) C+ j

* k# }- m9 T/ g'角球弧
# s: Z& d/ ~9 t1 W" f+ y7 y$ oang1 = ThisDrawing.Utility.AngleToReal(90, 0) '角度转换为弧度
- \# n1 E4 |3 H; j7 hang2 = ThisDrawing.Utility.AngleToReal(180, 0)
+ K4 C7 m# f8 i; I3 k( hlinep1(0) = centerp(0) + chang / 2 '角球弧圆心
linep1(1) = centerp(1) - kuan / 2
Call ThisDrawing.ModelSpace.AddArc(linep1, jqqr, ang1, ang2) '画弧
9 E: P' c: y$ H% Q
9 G0 ]" P0 i6 B2 e/ R5 C- J+ kang1 = ThisDrawing.Utility.AngleToReal(270, 0)
5 d/ s+ \/ C7 W0 g# n: {6 klinep1(1) = centerp(1) + kuan / 2
Call ThisDrawing.ModelSpace.AddArc(linep1, jqqr, ang2, ang1)

  e: d+ ~  c0 n
% \5 J" t6 j7 Q: y& v$ j# A
'镜像轴
linep1(0) = centerp(0)
linep1(1) = centerp(1) - kuan / 2
' ?. R* ], |1 i; |linep2(0) = centerp(0)
linep2(1) = centerp(1) + kuan / 2
' E/ B, E% e: D8 F
; W2 i# K) {  t'镜像
+ ^8 K+ Q5 M' z' xFor Each ent In ThisDrawing.ModelSpace '所有模型空间的对象进行一次循环
  If ent.Layer = "足球场" Then '对象在"足球场"图层中
; t0 \0 m: j) u4 ?" h+ E: H- a  [# L    ent.Mirror linep1, linep2 '镜像
  End If
Next ent
9 n! i- l) O) A$ B: N3 \9 \
, v% L" p5 o7 M1 w( p6 G0 \0 w  b'画中线
( S5 Z- ^% i( E( }$ mCall ThisDrawing.ModelSpace.AddLine(linep1, linep2)

. w/ M( ?9 D  `9 m+ v0 o'画中圈
Call ThisDrawing.ModelSpace.AddCircle(centerp, zqr)
6 y  V: p- G4 Z+ M6 j- f
& Z9 _4 @4 @2 J! Y  [) I' i7 f'画外框
linep1(0) = centerp(0) - chang / 2
linep1(1) = centerp(1) - kuan / 2
linep2(0) = centerp(0) + chang / 2
0 D7 z, f: _% o! d- ]" Dlinep2(1) = centerp(1) + kuan / 2
% R* p' H7 C2 hCall drawbox(linep1, linep2)
6 M- f3 N! s: B
2 f, M9 l# b+ h5 g, e) e# `1 aZoomExtents '显示整个图形

1 F) a/ Y2 R4 j% AEnd Sub
0 t4 t+ A# J( p; `
4 K6 B4 A  ^! V( l/ c' t0 O8 ?) pPrivate Sub drawbox(p1, p2) '根据对角线坐标画矩形的子程序
; k7 ?- i* D, h4 i% q# XDim boxp(0 To 14) As Double
7 s6 Y8 i+ J! S2 q9 P
3 z) C  C2 y. Z) h, D6 E# [- z. E3 |boxp(0) = p1(0)
boxp(1) = p1(1)
& O% e" U) |  K  j+ G
% j$ \( T; V$ E5 oboxp(3) = p1(0)
boxp(4) = p2(1)

& [& k: {, g, Q- q, p/ m3 V- sboxp(6) = p2(0)
: _0 I+ z% p$ n* r0 s! Kboxp(7) = p2(1)
% {* j4 ]) f( Y, O, g" n
boxp(9) = p2(0)
  v! n8 D; T- z, `* s1 K6 \- f6 i, fboxp(10) = p1(1)
- T6 [5 N7 s/ k/ [. f) H; a
boxp(12) = p1(0)
boxp(13) = p1(1)

1 A3 M0 {- v+ E, bCall ThisDrawing.ModelSpace.AddPolyline(boxp)
; m. g6 m& E; [2 O" {  {
' t% i# x9 s; Y! e# }End Sub

! Y- n+ Q6 `5 {

3 C: v7 [! E7 Q& W; W" {2 e7 f
5 Q" ]2 P/ O( Z4 Q下面开始分析源码：

On Error Resume Next
4 i5 q1 ~8 K3 k  k% qchang = ThisDrawing.Utility.GetReal("长度(90～120)<10500>")
8 b- Z9 `! D: h0 xIf Err.Number <> 0 Then '用户输入的不是有效数字
chang = 10500
Err.Clear '清除错误
End If
8 y  o0 p$ t* n; |4 ]* M7 J5 u
. a$ }3 N/ J* Q5 v: r" M    这段代码的作用是要求用户输入一个足球场长度的数字，由于getreal只能输入数字，如果输入其他字符程序就会报错，所以先要用去掉错误提示：On Error Resume Next，虽然错误不再提示，但是出错代码会err.number改变，有兴趣的读者可以用变量跟踪的方法看看这个代码的数值。您只要记住，如果这个数字不是0，那么就是有错了，这时就可以把长度定为默认值，然后用Err.Clear语句把错误代码清零。

  z# B0 Y% j# f1 u
( Y/ l& d' F. [7 L$ |. C    在画小禁区的最后一行这样写：Call drawbox(linep1, linep2)
8 h  c% s5 j5 v/ L3 E
    Drawbox并不是vba提供的方法，它是一个带参数的子程序。由于画足球场要画好几次矩形，
而vba没有提供一个现成的画矩形方法，如果每次都用一长串代码画矩形是很麻烦的，所以需要把这些麻烦的代码写到一个子程序中，在需要时只有写一条调用语句就行了。这个子程序最后几行，从“Private Sub drawbox(p1, p2) ”开始，到end sub结束，p1,p2是参数，调用时也必须写两个参数：linep1、linep2。


; }1 Z! s! |3 _* H1 Gang1 = ThisDrawing.Utility.AngleFromXAxis(linep1, linep3) '计算角度
- X( g6 q' O9 O5 o; j! hang2 = ThisDrawing.Utility.AngleFromXAxis(linep1, linep4)
  i- q6 a6 |3 z! S: D% v2 ICall ThisDrawing.ModelSpace.AddArc(linep1, zqr, ang1, ang2) '画弧

$ |4 t5 M3 g  T' V    画圆用addarc方法，需要4个参数：圆心、半径、起始角度、结束角度。AngleFromXAxis用于计算角度，其参数需要两个点坐标
; v+ M0 H) b% L% r4 }( y! ^; q
下面看镜像操作：
+ L& u/ p- y) P% d9 b7 b6 PFor Each ent In ThisDrawing.ModelSpace '所有模型空间的对象进行一次循环
2 M  I7 k) {) u. E6 m+ x  If ent.Layer = "足球场" Then '对象在"足球场"图层中
- X- G0 C9 |. w, t1 E    ent.Mirror linep1, linep2 '镜像
  End If
Next ent
# d3 e# ^8 _' O7 E7 D
    本例只对“足球场”图层中的对象进行镜像，所以要对全部对象进行循环，判断对象的图层属性，只有位于“足球场”图层中的对象才作镜像。
, }) ?9 N, O! U, D# c+ D/ T3 O
/ Z4 G" j2 Q  I2 z1 k
本课思考题：

) K% Y" I3 b, n( e( \2 i8 y1、对本课的例程进行修改，当用户输入长、宽不在规定的范围时要求用户重新输入

2 O7 t& d! a' ?2、设计一张简单的平面图，用户输入2个参数，其他尺寸写进程序中
, p% d) C7 C, P- {  L
[ 本帖最后由 tianyunxuan 于 2007-5-26 20:10 编辑 ]

tianyunxuan

定义块方法：

7 m) P, T7 P7 h- w$ T. H2 [Set blocksobj=ThisDrawing.Blocks.Add(基点, 块名)
把选择集加入块中的方法：
ThisDrawing.CopyObjects(选择集,块)
* k( _* q& b' I7 a插入块方法：
ThisDrawing.ModelSpace.InsertBlock(插入点,块名, X轴比例,Y轴比例,Z轴比例, 旋转角度)
- o" F/ G/ M: W$ W4 q/ y' R画块属性方法：
# l/ S% K6 z9 g1 ?9 k$ Z: NThisDrawing.ModelSpace.AddAttribute(文字高度,模式,提示字符, 插入点, 显示字符,默认值)
2 R/ o3 D$ X% Q" t7 @' W) b4 q' j& _一共有五种模式，在输入时会有提示，其中最常用的是“acAttributeModeNormal”普通模式
& u% o' \2 I0 q* @" X% R# W9 ^

( e" K* g! U# b" Z: ?5 q! K下面的例题是利用属性块画足球场的阵型图。
, \' E% d% S4 [( g# ~0 G$ W程序画出一个球员块，然后把块写到用户指定位置，球员号码由程序自动递增，把球员姓名改为用户输入值。画足球场请参阅上一课内容。
- M/ W" Q! r! C- F- I

1 G1 H+ a3 o/ R- ?
+ @8 f# K9 Q8 P3 ^2 ?
- G3 z: s, c/ p6 L8 \
+ w' P( F7 i3 `4 Z1 y5 ~9 y. o) ]( T
编程思路：
1．定义一个空块
2．在块中画一段弧（球服衣领）
' n0 r/ p) `1 Z3．画多段线，镜像画出球衣
4．画块属性，由于块属性默认的对齐方式是左对齐，而球员号码应该居中，所以必须把块的对齐属性改为居中。但是当这个属性更改时块属性对齐点会自动归零，所以不得不再次更改对齐点属性
5．把多段线和属性复制到块中
6．提示用户点选球员位置和姓名
) _1 x; C4 H/ h; X$ y3 D- t7．插入块，修改球衣号码属性、球员姓名属性
0 m6 O1 C4 [# {! N
. `4 f4 ^3 N: i. L以下是源码，附有详细的注释，如果有疑问，建议用变量跟踪法研究一下。
8 Q/ _  b* Q, u9 ?% |- t; L# u! eSub team()
Dim playerlay As AcadLayer '定义球员图层
Dim playerblock As AcadBlock '定义块变量
Dim arcc(0 To 2) As Double '圆弧圆心
& v. N1 u. W/ Y0 HDim linep1(0 To 2) As Double '线条端点1
Dim linep2(0 To 2) As Double '线条端点2
Dim pline(0 To 20) As Double '定义队服右侧多段线7个顶点
' s5 F4 g4 G) \Dim basep(0 To 2) As Double '块基点
Dim playernumberpoint(0 To 2) As Double '块属性插入点
- H' {2 G+ s# F+ v6 mDim mytxt As AcadTextStyle '定义mytxt变量为文本样式
Dim blockRef As AcadBlockReference '定义块属性变量
Dim Attr3 As Variant '插入块属性变量

. _4 U" N3 L# I- ~, U+ H- u; g( qSet playerblock = ThisDrawing.Blocks.Add(basep, "球员") '定义一个"球员"的块
! s7 M' O3 x! C
arcc(0) = 0
2 g5 q+ \( @. b# A* tarcc(1) = 430
Call playerblock.AddArc(arcc, 50, ThisDrawing.Utility.AngleToReal(180, 0), 0) '画弧并加入块中

pline(0) = 0
, W5 g2 c6 ~' v9 d) ~7 D6 x! jpline(1) = 20
, e7 w) M9 a! I1 z2 l
5 j# n5 `! |- x+ Hpline(3) = 100
* x& W: p0 p9 i9 cpline(4) = 20

pline(6) = 100
pline(7) = 250
+ x; }5 ]# Z; [* S% ~
pline(9) = 125
pline(10) = 207

pline(12) = 212
. I2 _; R  S- x8 F/ F" Apline(13) = 257
4 G3 f) q5 ]' s# f8 Q4 k: W( g

pline(15) = 112
. }. u% ~2 l8 o' v1 C$ _pline(16) = 430


* }' j& B! U  \  `& g# npline(18) = 50
pline(19) = 430

0 q5 B9 H+ C  ]  WSet line1 = ThisDrawing.ModelSpace.AddPolyline(pline) '画队服右侧多段线
) q" {5 w' x6 }8 o
linep2(1) = 1 '镜像轴第二点位于Y轴上任一点
Set line2 = line1.Mirror(linep1, linep2) '镜像获得另一半多段线

Dim p(0 To 2) As Double '定义坐标变量
Set mytxt = ThisDrawing.TextStyles.Add("mytxt") '添加mytxt样式
# E4 d$ H6 `  g$ f0 Y. h* i( imytxt.fontFile = "c:\windows\fonts\simfang.ttf" '设置字体文件为仿宋体
* h* L9 z" l! p" U1 HThisDrawing.ActiveTextStyle = mytxt '将当前文字样式设置为mytxt
# d0 V* G2 q. A) [+ T9 p
playernumberpoint(0) = 0 '块属性位置
playernumberpoint(1) = 200
* q, L: p% ?5 j5 F: w" \Set attr1 = ThisDrawing.ModelSpace.AddAttribute(100, acAttributeModeNormal, "号码", playernumberpoint, "X", 0) '画块属性
; `8 e7 b1 z+ M/ fattr1.Alignment = 7 '居中
3 q7 b% Q2 Q7 pattr1.TextAlignmentPoint = playernumberpoint '重定义对齐点
Set attr2 = ThisDrawing.ModelSpace.AddAttribute(100, acAttributeModeNormal, "姓名", playernumberpoint, "???", 0) '画块属性
attr2.Alignment = 7 '居中
. N& n& E9 s: `' ?" E; h* \+ ?0 W- Z/ E

Dim objCollection(0 To 3) As Object '创建选择集
Set objCollection(0) = line1 '线条1加入选择集
- ?; r9 ]2 r( q4 R/ i3 a( }2 Y6 bSet objCollection(1) = line2 '线条2加入选择集
& N* R3 O6 x* G$ BSet objCollection(2) = attr1 '属性1加入选择集
Set objCollection(3) = attr2 '属性2加入选择集

Call ThisDrawing.CopyObjects(objCollection, playerblock) '把选择集加入块中
2 P! B. T% N/ j& T# ^
* X( A& A* y( }* E8 P' S$ vFor Each element In objCollection '在选择集中进行循环
  element.Delete '删除线条和属性(此操作并不影响已创建的块)
Next
/ a3 S( z- F% L' L" e; ?, ?
9 {6 O8 `( y) C8 a! B0 I, N9 g
7 I* }1 {# U3 q' t# x! H' I' eSet playerlay = ThisDrawing.Layers.Add("球员") '新建图层
. h5 b. P& w! B+ [+ pplayerlay.color = 2 '为黄色
  a  \/ M- ^* f; k; u$ v( jThisDrawing.ActiveLayer = playerlay '将当前图层设置为球员图层
% b, T9 K3 p/ k/ Z9 p" [
0 ~1 ^' T6 S+ X# A# oDim p1 As Variant '块插入点位置

8 U) H" I# m% Q$ h: _3 N5 \2 vFor i = 1 To 11 '插入块
' q7 Z& v& }: B  pstring = CStr(i) & "号球员位置："
7 ^" z, p, K4 j3 A# u2 U  p1 = ThisDrawing.Utility.GetPoint(, pstring) '点选球员位置坐标
4 ]9 b5 m6 X" {8 j  nstring = ThisDrawing.Utility.GetString(30, "球员姓名：")
( V3 ~: n! d  R. O0 p( J1 q$ `  Set blockRef = ThisDrawing.ModelSpace.InsertBlock(p1, "球员", 1, 1, 1, 0) '插入块
  Attr3 = blockRef.GetAttributes '获取块属性
- o1 @4 ]1 o) R7 }8 e  Attr3(0).TextString = CStr(i) '赋值球员号码
  Attr3(1).TextString = nstring '赋值球员姓名
7 ~, |- L0 i' n9 f( k" ]Next
: F9 v5 a  B$ A* B5 z
End Sub

本课思考题：
6 \) p+ B' M  p, b' c8 q8 L1、在本课例程的最后一段增加出错陷阱代码，当用户输入非正常数值时退出程序
0 R7 w7 A/ c5 I" x$ z( d4 F# N, [0 k2、画一个简易路灯块，用属性块做为路灯编号，由用户点选路灯位置，程序画路灯时自动为路灯编号

trinco

很有帮助！谢谢lz

cgc

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

( p. r5 [- `, _" n" O, ?好好学习，感觉函数 方面还有很多的东西不是很懂

' V, E& ]% K4 a0 I( ^7 E+ o有函数库可以查阅么？

: \' e: `! ]" b买书也行

nebs

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

lianghn1986

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

pianpi111

auto cad vba第一次听说
学学

nebs

顶！！ 学习中.....

sod11791

太难了，能学会吗？

kyokula

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