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

pengyg1204

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

wangpiwujing

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

yhfsmu

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

设计从零

支持楼主！！！
！

hellmen

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

tianyunxuan

简单地讲，参数化设计就是根据参数进行精确绘图，绘图所需要的参数也可以由用户手工输入。真正的参数化设计往往需要数据库操作，为了简化程序，把数据库部分放在以后的课程中详细讲解。
1 K  M/ H$ a3 C( p1 ?, B
    本课的例程是画一个标准足球场。足球场长度90～120米，宽度45～90米，而红色标注的尺寸是程序默认的，绿色标注固定不变。

! e2 @) s, G- V2 j# Q* m


Sub court()
! h) R; s; i& ?2 Y! M3 f" W  eDim courtlay As AcadLayer '定义球场图层
' `: Z5 L8 U, H5 wDim ent As AcadEntity '镜像对象
Dim linep1(0 To 2) As Double '线条端点1
. I$ `; F& s8 g8 j7 D/ \2 O) QDim linep2(0 To 2) As Double '线条端点2
Dim linep3(0 To 2) As Double '罚球弧端点1
Dim linep4(0 To 2) As Double '罚球弧端点2
* X% w" x" W7 A$ c$ l$ o4 d0 Y. @Dim centerp As Variant '中心坐标
xjq = 11000 '小禁区尺寸
djq = 33000 '大禁区尺寸
3 S8 j% c8 y5 {! {* a0 kfqd = 11000 '罚球点位置
+ t/ M! }) J. W5 I0 @$ Ifqr = 9150 '罚球弧半径
fqh = 14634.98 '罚球弧弦长
8 J6 k8 O  b1 c& ~jqqr = 1000 '角球区半径
zqr = 9150 '中圈半径

On Error Resume Next
chang = ThisDrawing.Utility.GetReal("长度(90000～120000)<105000>")
If Err.Number <> 0 Then '用户输入的不是有效数字
( I( ^) X9 Y8 o: {% `# w: P  chang = 105000
  Err.Clear '清除错误
; W/ K% D$ _' X& [End If
) n, L' f( {$ |/ L. zkuan = ThisDrawing.Utility.GetReal("宽度(45000～90000)<68000>")
1 H0 [( n4 s& Z/ m- S8 ~/ VIf Err.Number <> 0 Then
  kuan = 68000
, h% p* |8 T9 j2 m% a& `+ n, vEnd If

centerp = ThisDrawing.Utility.GetPoint(, "定位球场中心:")
" I* Q0 M& L. p$ F4 Z5 C; ^+ R
Set courtlay = ThisDrawing.Layers.Add("足球场") '设置图层
ThisDrawing.ActiveLayer = courtlay '把当前图层设为足球场图层
8 E( d# h7 ]  H
'画小禁区
linep1(0) = centerp(0) + chang / 2
3 l8 D+ }1 Y- Wlinep1(1) = centerp(1) + xjq / 2
linep2(0) = centerp(0) + chang / 2 - xjq / 2
linep2(1) = centerp(1) - xjq / 2
- O$ ~# B5 I1 L! t( x0 V; QCall drawbox(linep1, linep2) '调用画矩形子程序
! o4 C' c! l5 e/ F' p$ n" d4 `- O8 b+ J/ E


'画大禁区
linep1(0) = centerp(0) + chang / 2
0 _0 q5 z6 M7 n. A( s7 U' a  N% |# Plinep1(1) = centerp(1) + djq / 2
! |. R" _+ I2 t. x( c) f7 x* S6 L7 B/ Flinep2(0) = centerp(0) + chang / 2 - djq / 2
4 m) J, s* V3 M7 Glinep2(1) = centerp(1) - djq / 2
3 S2 \( a( q! C) J* wCall drawbox(linep1, linep2)
) T0 p- R8 y/ l" Y* g
1 `' ^% g' M. X& y$ _
7 ?9 d9 h7 z* R+ ~; g9 U' 画罚球点
' W% y; i3 l* t( Tlinep1(0) = centerp(0) + chang / 2 - fqd
: x+ {5 Q/ l- k. b8 s) y( S9 ulinep1(1) = centerp(1)
Call ThisDrawing.ModelSpace.AddPoint(linep1)
'ThisDrawing.SetVariable "PDMODE", 32 '点样式
: o2 G+ c& Y0 k3 {) ^- mThisDrawing.SetVariable "PDSIZE", 30 '点的尺寸
# z  {$ V5 f' K  M6 z% e1 P
) ]5 `; ^3 m. t$ f! v'画罚球弧，罚球弧圆心就是罚球点linep1
linep3(0) = centerp(0) + chang / 2 - djq / 2
1 s- Z- K3 G0 b. {7 c, Zlinep3(1) = centerp(1) + fqh / 2
, m0 K. P7 l& k( n. Q8 X! hlinep4(0) = linep3(0) '两个端点的x轴相同
! |/ p% f6 b: a- T7 s8 Elinep4(1) = centerp(1) - fqh / 2
ang1 = ThisDrawing.Utility.AngleFromXAxis(linep1, linep3) '计算角度
ang2 = ThisDrawing.Utility.AngleFromXAxis(linep1, linep4)
. ]5 e! v' U& y, n% `" f7 [Call ThisDrawing.ModelSpace.AddArc(linep1, zqr, ang1, ang2) '画弧

4 M" i# _: q  {7 ]/ ?# o
0 l  ]3 R! P4 b% ]'角球弧
ang1 = ThisDrawing.Utility.AngleToReal(90, 0) '角度转换为弧度
3 j4 k% Y2 L$ q! r, mang2 = ThisDrawing.Utility.AngleToReal(180, 0)
( A$ |& c( j7 K% k* ilinep1(0) = centerp(0) + chang / 2 '角球弧圆心
. v7 y$ y9 L' }( t+ zlinep1(1) = centerp(1) - kuan / 2
. D" D2 x: B3 v' o' UCall ThisDrawing.ModelSpace.AddArc(linep1, jqqr, ang1, ang2) '画弧

ang1 = ThisDrawing.Utility.AngleToReal(270, 0)
- c1 `+ \, ~$ c- O, M2 b# v' o, b, Ulinep1(1) = centerp(1) + kuan / 2
Call ThisDrawing.ModelSpace.AddArc(linep1, jqqr, ang2, ang1)
6 v2 H- O* Q; |! N
3 ~: p$ ^$ q* r# o( h
8 y  C* v% O  S0 H4 n: b
'镜像轴
linep1(0) = centerp(0)
7 K2 X) S0 D) o" f5 h) l0 Wlinep1(1) = centerp(1) - kuan / 2
" n! \+ L; M3 E, a: K5 [9 }linep2(0) = centerp(0)
, k4 \+ S) M" b" C6 m$ `linep2(1) = centerp(1) + kuan / 2

2 R  A5 ~% E. X, g) K/ \'镜像
For Each ent In ThisDrawing.ModelSpace '所有模型空间的对象进行一次循环
6 @0 F9 T9 b! Y5 a# }, P  If ent.Layer = "足球场" Then '对象在"足球场"图层中
2 }! h5 g. M. T9 _7 {" B    ent.Mirror linep1, linep2 '镜像
2 Y6 E6 [7 b7 J( y/ J1 o% M& s& m  End If
Next ent
: T0 a) W6 `9 E( N
'画中线
Call ThisDrawing.ModelSpace.AddLine(linep1, linep2)
6 d7 w1 Q0 \  v% \& R" t# G  ^
'画中圈
0 C+ n4 p7 Y- i2 \Call ThisDrawing.ModelSpace.AddCircle(centerp, zqr)
! g, P! N1 k* a) k4 y8 k( y* {3 h
, s$ A; n4 A4 }( v* K( f0 l  L'画外框
' L( w+ g" s) s! ?* S- j* }! ^! `3 ~4 Slinep1(0) = centerp(0) - chang / 2
" V9 t9 S8 Q4 ^* |: U8 w' ?linep1(1) = centerp(1) - kuan / 2
% \: G9 p" G; P, j, @( glinep2(0) = centerp(0) + chang / 2
- |0 \7 u; J% g: p) zlinep2(1) = centerp(1) + kuan / 2
% A* I9 Z; F8 z5 N1 VCall drawbox(linep1, linep2)

0 c$ e2 O. @3 G+ e  F; t2 BZoomExtents '显示整个图形

End Sub
- E5 |" F& h" i4 z% U
Private Sub drawbox(p1, p2) '根据对角线坐标画矩形的子程序
Dim boxp(0 To 14) As Double

* v: i# o- H! H3 |boxp(0) = p1(0)
boxp(1) = p1(1)

( d! ^% s/ i& Gboxp(3) = p1(0)
  s/ C+ ~. Q+ |! h* `boxp(4) = p2(1)

: n! m% j( t  e4 S, oboxp(6) = p2(0)
boxp(7) = p2(1)
; u# v) E8 x% w
9 P3 [" F+ P4 c: Qboxp(9) = p2(0)
5 N0 H% ]; `8 e" T# g% dboxp(10) = p1(1)

boxp(12) = p1(0)
! @; c$ ?  k& j* X0 ~2 V/ aboxp(13) = p1(1)
9 V# V3 B% w. f" N: D" c* o+ Q
Call ThisDrawing.ModelSpace.AddPolyline(boxp)

5 k: f, g' ], uEnd Sub



- G, V- R" z% m, S& V4 W; f- O: n
; C9 s8 v% i+ X5 K) v- z下面开始分析源码：
; i. `0 J% o  O3 H$ v0 m
On Error Resume Next
chang = ThisDrawing.Utility.GetReal("长度(90～120)<10500>")
" ^. O8 t4 w! P% V- mIf Err.Number <> 0 Then '用户输入的不是有效数字
chang = 10500
. @: f  |* R, I. _6 M  B- ^Err.Clear '清除错误
# k  O0 \! E, g# ?, I1 X9 |# EEnd If
* o2 T' f1 K& }. b# I
8 y0 ^  }" ^0 _; K# W$ I5 J    这段代码的作用是要求用户输入一个足球场长度的数字，由于getreal只能输入数字，如果输入其他字符程序就会报错，所以先要用去掉错误提示：On Error Resume Next，虽然错误不再提示，但是出错代码会err.number改变，有兴趣的读者可以用变量跟踪的方法看看这个代码的数值。您只要记住，如果这个数字不是0，那么就是有错了，这时就可以把长度定为默认值，然后用Err.Clear语句把错误代码清零。

1 \9 h" n( [+ \, r
    在画小禁区的最后一行这样写：Call drawbox(linep1, linep2)
( i- Z3 \2 A, v8 ]$ f
    Drawbox并不是vba提供的方法，它是一个带参数的子程序。由于画足球场要画好几次矩形，
& X" h9 ~, p5 }2 o而vba没有提供一个现成的画矩形方法，如果每次都用一长串代码画矩形是很麻烦的，所以需要把这些麻烦的代码写到一个子程序中，在需要时只有写一条调用语句就行了。这个子程序最后几行，从“Private Sub drawbox(p1, p2) ”开始，到end sub结束，p1,p2是参数，调用时也必须写两个参数：linep1、linep2。


ang1 = ThisDrawing.Utility.AngleFromXAxis(linep1, linep3) '计算角度
) x0 M: t3 w5 W7 t; Sang2 = ThisDrawing.Utility.AngleFromXAxis(linep1, linep4)
Call ThisDrawing.ModelSpace.AddArc(linep1, zqr, ang1, ang2) '画弧

2 s1 y4 y3 t. n. W3 C3 I    画圆用addarc方法，需要4个参数：圆心、半径、起始角度、结束角度。AngleFromXAxis用于计算角度，其参数需要两个点坐标

下面看镜像操作：
For Each ent In ThisDrawing.ModelSpace '所有模型空间的对象进行一次循环
; F  z. Z$ c, |9 U& y& o  If ent.Layer = "足球场" Then '对象在"足球场"图层中
- k3 D% d& B/ c  S/ g    ent.Mirror linep1, linep2 '镜像
  End If
Next ent

    本例只对“足球场”图层中的对象进行镜像，所以要对全部对象进行循环，判断对象的图层属性，只有位于“足球场”图层中的对象才作镜像。


本课思考题：

1、对本课的例程进行修改，当用户输入长、宽不在规定的范围时要求用户重新输入

3 f' ?; j7 Q# K. a/ |2、设计一张简单的平面图，用户输入2个参数，其他尺寸写进程序中

[ 本帖最后由 tianyunxuan 于 2007-5-26 20:10 编辑 ]

tianyunxuan

定义块方法：
. F8 Y/ b) P3 `3 a+ w% C6 L& b
9 E2 ?8 Q  o. a5 T: ]Set blocksobj=ThisDrawing.Blocks.Add(基点, 块名)
把选择集加入块中的方法：
9 i% u$ q1 `1 w, s. E7 [" zThisDrawing.CopyObjects(选择集,块)
4 x3 e" e" y% e& w5 S插入块方法：
ThisDrawing.ModelSpace.InsertBlock(插入点,块名, X轴比例,Y轴比例,Z轴比例, 旋转角度)
画块属性方法：
ThisDrawing.ModelSpace.AddAttribute(文字高度,模式,提示字符, 插入点, 显示字符,默认值)
一共有五种模式，在输入时会有提示，其中最常用的是“acAttributeModeNormal”普通模式
2 e  t- c" R$ r

# h' L  q" i! O6 J+ k# M' k下面的例题是利用属性块画足球场的阵型图。
程序画出一个球员块，然后把块写到用户指定位置，球员号码由程序自动递增，把球员姓名改为用户输入值。画足球场请参阅上一课内容。
# C$ @$ Z; U( q3 Y) q1 o6 e. U


# C7 w/ n3 `6 P1 }$ M

9 h/ ~. e' W+ W7 ^
编程思路：
7 Q% u  z5 w9 P1．定义一个空块
2．在块中画一段弧（球服衣领）
3．画多段线，镜像画出球衣
4．画块属性，由于块属性默认的对齐方式是左对齐，而球员号码应该居中，所以必须把块的对齐属性改为居中。但是当这个属性更改时块属性对齐点会自动归零，所以不得不再次更改对齐点属性
5．把多段线和属性复制到块中
6．提示用户点选球员位置和姓名
7．插入块，修改球衣号码属性、球员姓名属性

以下是源码，附有详细的注释，如果有疑问，建议用变量跟踪法研究一下。
Sub team()
$ @# `$ l7 O/ F6 G% P9 n/ QDim playerlay As AcadLayer '定义球员图层
Dim playerblock As AcadBlock '定义块变量
Dim arcc(0 To 2) As Double '圆弧圆心
2 O$ w- q2 j2 e3 ^& X$ Y3 l- ZDim linep1(0 To 2) As Double '线条端点1
" J% D8 V0 u1 W  g: CDim linep2(0 To 2) As Double '线条端点2
Dim pline(0 To 20) As Double '定义队服右侧多段线7个顶点
Dim basep(0 To 2) As Double '块基点
Dim playernumberpoint(0 To 2) As Double '块属性插入点
: l+ @, ?4 Q/ i0 C5 m/ I' uDim mytxt As AcadTextStyle '定义mytxt变量为文本样式
& [' f- ^4 ~+ [, }6 q: D" M2 n; l8 DDim blockRef As AcadBlockReference '定义块属性变量
% g0 [, V7 U  L! wDim Attr3 As Variant '插入块属性变量

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

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

pline(0) = 0
3 h2 i. b- i7 {/ I7 cpline(1) = 20
" `7 b; y! X( B4 Z& [
pline(3) = 100
pline(4) = 20
0 {/ Q, v$ i' G, m+ w1 j
& ]4 f$ h3 q8 p) W7 ^pline(6) = 100
pline(7) = 250
4 P% ?4 ^$ `5 a- x- f. x
pline(9) = 125
pline(10) = 207

pline(12) = 212
pline(13) = 257
' b) Q# F: G9 `

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

2 l) T3 G  e( F
pline(18) = 50
" E4 ?2 Q* B/ x7 y( l1 Spline(19) = 430

Set line1 = ThisDrawing.ModelSpace.AddPolyline(pline) '画队服右侧多段线
' o% Z, l2 }" V+ L; p* I" K" D) u
linep2(1) = 1 '镜像轴第二点位于Y轴上任一点
0 o, o+ s' B4 X" d$ aSet line2 = line1.Mirror(linep1, linep2) '镜像获得另一半多段线

Dim p(0 To 2) As Double '定义坐标变量
Set mytxt = ThisDrawing.TextStyles.Add("mytxt") '添加mytxt样式
+ M, W! s2 T% bmytxt.fontFile = "c:\windows\fonts\simfang.ttf" '设置字体文件为仿宋体
ThisDrawing.ActiveTextStyle = mytxt '将当前文字样式设置为mytxt

2 G% x0 V& I) n6 V3 |playernumberpoint(0) = 0 '块属性位置
) J4 }! {& \8 `5 pplayernumberpoint(1) = 200
Set attr1 = ThisDrawing.ModelSpace.AddAttribute(100, acAttributeModeNormal, "号码", playernumberpoint, "X", 0) '画块属性
attr1.Alignment = 7 '居中
/ O* e( E: l$ b4 Kattr1.TextAlignmentPoint = playernumberpoint '重定义对齐点
Set attr2 = ThisDrawing.ModelSpace.AddAttribute(100, acAttributeModeNormal, "姓名", playernumberpoint, "???", 0) '画块属性
  c# Z$ m$ w9 h: ~5 H+ Rattr2.Alignment = 7 '居中

: N+ M1 a% n9 M* p# X
Dim objCollection(0 To 3) As Object '创建选择集
5 i+ s3 {. l' W8 m: h' tSet objCollection(0) = line1 '线条1加入选择集
Set objCollection(1) = line2 '线条2加入选择集
, z- A0 _$ `( b; \# z/ |+ y' iSet objCollection(2) = attr1 '属性1加入选择集
Set objCollection(3) = attr2 '属性2加入选择集

Call ThisDrawing.CopyObjects(objCollection, playerblock) '把选择集加入块中
7 s  e5 {" ^) y
For Each element In objCollection '在选择集中进行循环
9 H3 e; m% `" [( }; [, P  element.Delete '删除线条和属性(此操作并不影响已创建的块)
Next

  v# ^. |& }/ @7 ]+ k4 I( q( ^& x
Set playerlay = ThisDrawing.Layers.Add("球员") '新建图层
playerlay.color = 2 '为黄色
ThisDrawing.ActiveLayer = playerlay '将当前图层设置为球员图层
, `2 T( o2 [4 [7 ~+ a* F
7 n* z: o' x. c1 R+ o; KDim p1 As Variant '块插入点位置
, u; x! p( f6 T7 w" K' W0 d
7 f# |$ X9 B" ^* UFor i = 1 To 11 '插入块
  pstring = CStr(i) & "号球员位置："
  p1 = ThisDrawing.Utility.GetPoint(, pstring) '点选球员位置坐标
0 q; r. {9 |+ t  nstring = ThisDrawing.Utility.GetString(30, "球员姓名：")
! u. G6 Z" j! E* z5 M8 v5 F  Set blockRef = ThisDrawing.ModelSpace.InsertBlock(p1, "球员", 1, 1, 1, 0) '插入块
  Attr3 = blockRef.GetAttributes '获取块属性
. H9 V/ M" d& f8 a( Z  Attr3(0).TextString = CStr(i) '赋值球员号码
# i5 y! n/ [6 V  Attr3(1).TextString = nstring '赋值球员姓名
Next

5 `, L  V6 ~. q/ ^$ j8 M* ], p7 aEnd Sub

本课思考题：
) i3 K: R- W: B. U1、在本课例程的最后一段增加出错陷阱代码，当用户输入非正常数值时退出程序
0 o. h; {* v7 n$ o; s3 Z) M2、画一个简易路灯块，用属性块做为路灯编号，由用户点选路灯位置，程序画路灯时自动为路灯编号

trinco

很有帮助！谢谢lz

cgc

终于看好了，写得很不错， 连我从来不写程序的人都能看得懂了
" b2 d. u$ v+ g/ G& s* t
好好学习，感觉函数 方面还有很多的东西不是很懂
- s( A* \6 q" [* A
, w5 h! k, I/ l; c. l有函数库可以查阅么？
* \) B. _$ X* A1 l7 {1 |
买书也行

nebs

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

lianghn1986

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

pianpi111

auto cad vba第一次听说
, u+ d  r* V1 n; Q学学

nebs

顶！！ 学习中.....

sod11791

太难了，能学会吗？

kyokula

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