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

pengyg1204

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

wangpiwujing

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

yhfsmu

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

设计从零

支持楼主！！！
; J- I- A/ t6 n/ q, E！

hellmen

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

tianyunxuan

简单地讲，参数化设计就是根据参数进行精确绘图，绘图所需要的参数也可以由用户手工输入。真正的参数化设计往往需要数据库操作，为了简化程序，把数据库部分放在以后的课程中详细讲解。
  Y& W7 X1 x2 D4 R
0 N: `* h1 `- e5 b+ t  C8 S    本课的例程是画一个标准足球场。足球场长度90～120米，宽度45～90米，而红色标注的尺寸是程序默认的，绿色标注固定不变。


6 S: ?' _7 a8 F6 |

2 |+ D7 q& G* n4 ?Sub court()
3 F! L/ h! }3 x( T# ^. W; \Dim courtlay As AcadLayer '定义球场图层
' O. K9 Z3 L- u( NDim ent As AcadEntity '镜像对象
Dim linep1(0 To 2) As Double '线条端点1
" }2 ]! B8 m; z0 |; y+ Q  K' ~2 y! GDim linep2(0 To 2) As Double '线条端点2
Dim linep3(0 To 2) As Double '罚球弧端点1
) h) E( t& X/ _' cDim linep4(0 To 2) As Double '罚球弧端点2
' J' n+ h! b, _! ]( UDim centerp As Variant '中心坐标
( w; p( Y( ?3 J: cxjq = 11000 '小禁区尺寸
djq = 33000 '大禁区尺寸
fqd = 11000 '罚球点位置
fqr = 9150 '罚球弧半径
0 z4 m1 q4 v9 H3 J& Q" w" pfqh = 14634.98 '罚球弧弦长
jqqr = 1000 '角球区半径
zqr = 9150 '中圈半径
! @: |  M: R5 M$ O. w* V' q
+ `/ y! y! R* Y- M; C3 F: JOn Error Resume Next
" E; Q4 I# p5 }, S7 R; b, J- echang = ThisDrawing.Utility.GetReal("长度(90000～120000)<105000>")
& n2 T! G  N+ w( e% R: RIf Err.Number <> 0 Then '用户输入的不是有效数字
+ R3 ?# a* G/ X4 r4 }. U  chang = 105000
  Err.Clear '清除错误
, z# ?4 m) P- _( {: NEnd If
kuan = ThisDrawing.Utility.GetReal("宽度(45000～90000)<68000>")
% t' o. v" j$ ?# sIf Err.Number <> 0 Then
  kuan = 68000
* q- {9 B1 c8 F4 [; }5 j5 ]' oEnd If

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

Set courtlay = ThisDrawing.Layers.Add("足球场") '设置图层
% y% y- D$ X. E) e8 ~. r/ [9 CThisDrawing.ActiveLayer = courtlay '把当前图层设为足球场图层

'画小禁区
linep1(0) = centerp(0) + chang / 2
linep1(1) = centerp(1) + xjq / 2
linep2(0) = centerp(0) + chang / 2 - xjq / 2
linep2(1) = centerp(1) - xjq / 2
Call drawbox(linep1, linep2) '调用画矩形子程序

1 `* G0 a+ i; p4 @) b3 ?  N/ I+ g, s
" q9 Z8 [6 I+ j$ x
0 U4 A' a# d( F$ t'画大禁区
: V2 Y# K5 v  F& [5 D9 Q2 e. S0 Dlinep1(0) = centerp(0) + chang / 2
linep1(1) = centerp(1) + djq / 2
linep2(0) = centerp(0) + chang / 2 - djq / 2
: U$ @1 h; `" r5 W( e+ n5 Blinep2(1) = centerp(1) - djq / 2
Call drawbox(linep1, linep2)
6 u9 U0 m# m, s; @% e7 I

6 W2 Y) c& w. o+ F3 I# J' 画罚球点
( G. s+ V! R% I% Y+ f: l- t* slinep1(0) = centerp(0) + chang / 2 - fqd
1 C4 `; Q) ~% M7 \8 ~: W2 T! Plinep1(1) = centerp(1)
/ F; x+ o# h* rCall ThisDrawing.ModelSpace.AddPoint(linep1)
'ThisDrawing.SetVariable "PDMODE", 32 '点样式
+ E- u% f! p+ X- ?. u- |- Y! Y  X! rThisDrawing.SetVariable "PDSIZE", 30 '点的尺寸

'画罚球弧，罚球弧圆心就是罚球点linep1
% c6 o+ @5 x! R# }) x: P' Llinep3(0) = centerp(0) + chang / 2 - djq / 2
5 D% B" m# d  C3 A6 t% i5 Klinep3(1) = centerp(1) + fqh / 2
/ s1 N# K! a# I. a  \5 _# tlinep4(0) = linep3(0) '两个端点的x轴相同
, \' O4 f, a& l7 J) r, t) y; Rlinep4(1) = centerp(1) - fqh / 2
ang1 = ThisDrawing.Utility.AngleFromXAxis(linep1, linep3) '计算角度
! v! U& I- o9 y; f  Cang2 = ThisDrawing.Utility.AngleFromXAxis(linep1, linep4)
Call ThisDrawing.ModelSpace.AddArc(linep1, zqr, ang1, ang2) '画弧


5 a2 Y5 l: y  f' K; y'角球弧
, ]4 M! a3 m7 m$ x5 Oang1 = ThisDrawing.Utility.AngleToReal(90, 0) '角度转换为弧度
ang2 = ThisDrawing.Utility.AngleToReal(180, 0)
linep1(0) = centerp(0) + chang / 2 '角球弧圆心
linep1(1) = centerp(1) - kuan / 2
( Q1 ]8 W+ X7 bCall ThisDrawing.ModelSpace.AddArc(linep1, jqqr, ang1, ang2) '画弧
5 F" u+ z- l! I% A; U2 x# A
ang1 = ThisDrawing.Utility.AngleToReal(270, 0)
/ p% j( U- {  a: T0 o9 h- L( Nlinep1(1) = centerp(1) + kuan / 2
Call ThisDrawing.ModelSpace.AddArc(linep1, jqqr, ang2, ang1)


" ^% \, Y5 A- f3 n' |) f
$ e$ n5 o3 v5 @1 [1 ]' q'镜像轴
: j  w, v* q; f! x. d4 Q4 Qlinep1(0) = centerp(0)
  ^6 N- @1 q, J9 q- ?* rlinep1(1) = centerp(1) - kuan / 2
. m4 V% S. P: Vlinep2(0) = centerp(0)
linep2(1) = centerp(1) + kuan / 2

0 O" d2 l( P- E'镜像
For Each ent In ThisDrawing.ModelSpace '所有模型空间的对象进行一次循环
  If ent.Layer = "足球场" Then '对象在"足球场"图层中
    ent.Mirror linep1, linep2 '镜像
  i! G4 Q5 A0 Y: x% l7 c  End If
Next ent
/ j$ |7 l% \+ N  ?- o
'画中线
( _! A& \8 n# m& }$ k' L! uCall ThisDrawing.ModelSpace.AddLine(linep1, linep2)
6 A. z) ^- z5 n
'画中圈
Call ThisDrawing.ModelSpace.AddCircle(centerp, zqr)
; X- d$ h5 U5 i" N+ E
'画外框
linep1(0) = centerp(0) - chang / 2
5 R# ]( s3 ^0 A; Mlinep1(1) = centerp(1) - kuan / 2
7 x3 o9 M- G1 Ilinep2(0) = centerp(0) + chang / 2
linep2(1) = centerp(1) + kuan / 2
Call drawbox(linep1, linep2)

ZoomExtents '显示整个图形

End Sub
, n+ Z$ F; V% ]2 a" D$ m/ z
! s2 `" t( }0 dPrivate Sub drawbox(p1, p2) '根据对角线坐标画矩形的子程序
Dim boxp(0 To 14) As Double

boxp(0) = p1(0)
6 j3 b! o. ~  m4 C% d! Y- B- u' x/ E2 aboxp(1) = p1(1)
0 @* Y: q+ U( o; ?' F! D- G' q* r
boxp(3) = p1(0)
! p5 R; |% k; ?. Y; g. [boxp(4) = p2(1)
1 z; L/ `: a: G3 L0 C" G; o# Y
5 L. g; l6 R! _; b! |boxp(6) = p2(0)
' j& v. J3 R2 S6 |boxp(7) = p2(1)

boxp(9) = p2(0)
9 Q8 Y; H# l8 K) {/ q- Gboxp(10) = p1(1)
% y) k7 W0 m' `4 I4 y* V; k
boxp(12) = p1(0)
boxp(13) = p1(1)

2 _) A  q4 n( n( @Call ThisDrawing.ModelSpace.AddPolyline(boxp)
, t( X: K- E" v! _0 s2 z
: H% P. C2 P8 F& z- h6 Y9 VEnd Sub




下面开始分析源码：

: [6 h& a' a" {3 WOn Error Resume Next
1 I/ b4 C5 H: rchang = ThisDrawing.Utility.GetReal("长度(90～120)<10500>")
If Err.Number <> 0 Then '用户输入的不是有效数字
4 i) m9 V2 D9 h/ U) @9 ?3 dchang = 10500
% o& W7 y# V! n/ @& _/ e( I; ~6 lErr.Clear '清除错误
7 {4 b9 L/ D, o. ]! ?0 REnd If

    这段代码的作用是要求用户输入一个足球场长度的数字，由于getreal只能输入数字，如果输入其他字符程序就会报错，所以先要用去掉错误提示：On Error Resume Next，虽然错误不再提示，但是出错代码会err.number改变，有兴趣的读者可以用变量跟踪的方法看看这个代码的数值。您只要记住，如果这个数字不是0，那么就是有错了，这时就可以把长度定为默认值，然后用Err.Clear语句把错误代码清零。


    在画小禁区的最后一行这样写：Call drawbox(linep1, linep2)

    Drawbox并不是vba提供的方法，它是一个带参数的子程序。由于画足球场要画好几次矩形，
而vba没有提供一个现成的画矩形方法，如果每次都用一长串代码画矩形是很麻烦的，所以需要把这些麻烦的代码写到一个子程序中，在需要时只有写一条调用语句就行了。这个子程序最后几行，从“Private Sub drawbox(p1, p2) ”开始，到end sub结束，p1,p2是参数，调用时也必须写两个参数：linep1、linep2。
/ t0 |# f. I. Y% o

3 p; c% O, P, b( w) a4 s2 aang1 = ThisDrawing.Utility.AngleFromXAxis(linep1, linep3) '计算角度
! n, F5 [3 I+ D9 zang2 = ThisDrawing.Utility.AngleFromXAxis(linep1, linep4)
! {# _2 E# z2 _& ]5 pCall ThisDrawing.ModelSpace.AddArc(linep1, zqr, ang1, ang2) '画弧

    画圆用addarc方法，需要4个参数：圆心、半径、起始角度、结束角度。AngleFromXAxis用于计算角度，其参数需要两个点坐标
- R5 l% e4 q: X& }0 X8 W) S" m
下面看镜像操作：
For Each ent In ThisDrawing.ModelSpace '所有模型空间的对象进行一次循环
2 A5 V- |; R# _5 A' B5 H, W/ a  If ent.Layer = "足球场" Then '对象在"足球场"图层中
    ent.Mirror linep1, linep2 '镜像
$ z" \+ [) P. L" d& }; Z3 i% E; V  End If
5 K/ T0 x# G% r! L. j% W! CNext ent
- s8 J4 u. E" q1 y4 f- L8 L5 M$ F; P+ T
    本例只对“足球场”图层中的对象进行镜像，所以要对全部对象进行循环，判断对象的图层属性，只有位于“足球场”图层中的对象才作镜像。

& {' M( G) t+ f
" `, `4 e$ L( O& ?) H$ `# k本课思考题：

, v' P- ^( {+ d* y# K4 I1、对本课的例程进行修改，当用户输入长、宽不在规定的范围时要求用户重新输入
  |3 v& g' q0 J; ]* t: n4 J/ N% r
2、设计一张简单的平面图，用户输入2个参数，其他尺寸写进程序中

7 Y% d* m7 J9 S[ 本帖最后由 tianyunxuan 于 2007-5-26 20:10 编辑 ]

tianyunxuan

定义块方法：

: W3 N* `8 }$ T7 s+ nSet blocksobj=ThisDrawing.Blocks.Add(基点, 块名)
8 A7 ]) a8 |; J1 w+ `6 W$ X7 l把选择集加入块中的方法：
  ~/ Y# k/ j3 }! WThisDrawing.CopyObjects(选择集,块)
2 {$ @* v, e; F% ^7 P8 V插入块方法：
ThisDrawing.ModelSpace.InsertBlock(插入点,块名, X轴比例,Y轴比例,Z轴比例, 旋转角度)
画块属性方法：
1 c- N( B9 ~( K9 o' l. ?$ yThisDrawing.ModelSpace.AddAttribute(文字高度,模式,提示字符, 插入点, 显示字符,默认值)
一共有五种模式，在输入时会有提示，其中最常用的是“acAttributeModeNormal”普通模式


下面的例题是利用属性块画足球场的阵型图。
程序画出一个球员块，然后把块写到用户指定位置，球员号码由程序自动递增，把球员姓名改为用户输入值。画足球场请参阅上一课内容。
+ S+ O5 M: l$ Z6 v, |/ ~# m! O
+ S5 j, V" F! [4 a1 O7 @

5 U/ O$ Q6 A  m: ~
7 ]; R8 Q" N2 \

/ W( r/ `- o3 m1 q  n* W  J编程思路：
1．定义一个空块
2．在块中画一段弧（球服衣领）
3．画多段线，镜像画出球衣
4．画块属性，由于块属性默认的对齐方式是左对齐，而球员号码应该居中，所以必须把块的对齐属性改为居中。但是当这个属性更改时块属性对齐点会自动归零，所以不得不再次更改对齐点属性
5．把多段线和属性复制到块中
( T' p( e) j' o4 K7 l( ?: k; d6．提示用户点选球员位置和姓名
+ {; ?# [& P3 |4 l# z& J) a7．插入块，修改球衣号码属性、球员姓名属性

以下是源码，附有详细的注释，如果有疑问，建议用变量跟踪法研究一下。
Sub team()
Dim playerlay As AcadLayer '定义球员图层
' `8 n' w# s$ l% M3 _  R# Z" {Dim playerblock As AcadBlock '定义块变量
: a5 k1 Q8 u, Z$ N9 Q' g) BDim arcc(0 To 2) As Double '圆弧圆心
Dim linep1(0 To 2) As Double '线条端点1
% D3 B1 X! L1 [3 u' f% dDim linep2(0 To 2) As Double '线条端点2
2 ^- h1 `+ }- q& q) YDim pline(0 To 20) As Double '定义队服右侧多段线7个顶点
' _7 r& `# ~: L  d# TDim basep(0 To 2) As Double '块基点
: H' k% K' ?# S1 a! KDim playernumberpoint(0 To 2) As Double '块属性插入点
4 K! H$ B! N" B, qDim mytxt As AcadTextStyle '定义mytxt变量为文本样式
* [# o, I' G, `Dim blockRef As AcadBlockReference '定义块属性变量
  v" E5 U$ w" D# G& sDim Attr3 As Variant '插入块属性变量

* {: ^$ [& G% f+ K& S. |9 LSet playerblock = ThisDrawing.Blocks.Add(basep, "球员") '定义一个"球员"的块
- U5 [) K8 W2 B. M) F5 u2 A
5 j0 S' B0 T5 K, u7 @& i" D5 E: s! Farcc(0) = 0
arcc(1) = 430
Call playerblock.AddArc(arcc, 50, ThisDrawing.Utility.AngleToReal(180, 0), 0) '画弧并加入块中

pline(0) = 0
pline(1) = 20
6 N6 B! x1 E* f; r' T
pline(3) = 100
pline(4) = 20

pline(6) = 100
pline(7) = 250
$ v; T; }+ C! o* H, J
pline(9) = 125
pline(10) = 207

pline(12) = 212
/ V8 A4 D5 k0 k+ U; B+ a4 Jpline(13) = 257


2 o' R) y: a7 I4 O5 Tpline(15) = 112
pline(16) = 430


pline(18) = 50
pline(19) = 430
6 O& P, y8 l7 f7 G# ~
Set line1 = ThisDrawing.ModelSpace.AddPolyline(pline) '画队服右侧多段线
9 y* L: H1 m* H) N+ N
/ w5 P! q; m+ D& G  klinep2(1) = 1 '镜像轴第二点位于Y轴上任一点
Set line2 = line1.Mirror(linep1, linep2) '镜像获得另一半多段线

! Y+ `- \- G& f3 y1 r) IDim p(0 To 2) As Double '定义坐标变量
Set mytxt = ThisDrawing.TextStyles.Add("mytxt") '添加mytxt样式
mytxt.fontFile = "c:\windows\fonts\simfang.ttf" '设置字体文件为仿宋体
ThisDrawing.ActiveTextStyle = mytxt '将当前文字样式设置为mytxt
, |9 Q; L8 {, o
playernumberpoint(0) = 0 '块属性位置
# X; Z5 J2 s/ a9 [" ^playernumberpoint(1) = 200
2 k( q$ t* H* ]- e# U) s* v: vSet attr1 = ThisDrawing.ModelSpace.AddAttribute(100, acAttributeModeNormal, "号码", playernumberpoint, "X", 0) '画块属性
attr1.Alignment = 7 '居中
2 ?/ d! i5 P4 [6 G3 T2 Eattr1.TextAlignmentPoint = playernumberpoint '重定义对齐点
Set attr2 = ThisDrawing.ModelSpace.AddAttribute(100, acAttributeModeNormal, "姓名", playernumberpoint, "???", 0) '画块属性
9 d8 L% P7 L0 }. M) `9 wattr2.Alignment = 7 '居中
$ @! s9 q% {  W! G6 t
$ \2 W) p% x6 ^. O/ ]1 D
Dim objCollection(0 To 3) As Object '创建选择集
Set objCollection(0) = line1 '线条1加入选择集
Set objCollection(1) = line2 '线条2加入选择集
! ~! B: m3 h' j/ `2 OSet objCollection(2) = attr1 '属性1加入选择集
, C. b  P( \% G1 FSet objCollection(3) = attr2 '属性2加入选择集

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

For Each element In objCollection '在选择集中进行循环
) V+ Z  y( }4 I/ J  K" }, L  element.Delete '删除线条和属性(此操作并不影响已创建的块)
Next


Set playerlay = ThisDrawing.Layers.Add("球员") '新建图层
playerlay.color = 2 '为黄色
ThisDrawing.ActiveLayer = playerlay '将当前图层设置为球员图层

Dim p1 As Variant '块插入点位置
- H7 N9 ]0 s$ u1 o
! g  s- |- ~9 C; l. wFor i = 1 To 11 '插入块
% R% E! j. y. D  pstring = CStr(i) & "号球员位置："
2 p/ q. e6 V9 v2 t. m( ~+ j  p1 = ThisDrawing.Utility.GetPoint(, pstring) '点选球员位置坐标
  nstring = ThisDrawing.Utility.GetString(30, "球员姓名：")
8 m* c$ P" f9 K; D. B  Set blockRef = ThisDrawing.ModelSpace.InsertBlock(p1, "球员", 1, 1, 1, 0) '插入块
. u- {, ?  q" M- N) Z1 j3 {2 Z4 A! T' ?  Attr3 = blockRef.GetAttributes '获取块属性
  Attr3(0).TextString = CStr(i) '赋值球员号码
& Y) L; |# |6 f  Attr3(1).TextString = nstring '赋值球员姓名
Next
$ k4 i6 n# A: j( `/ w4 g2 e9 ^' }; N
End Sub
" H5 j( k1 C' `7 @7 ~. h3 b( c! @
本课思考题：
1、在本课例程的最后一段增加出错陷阱代码，当用户输入非正常数值时退出程序
2、画一个简易路灯块，用属性块做为路灯编号，由用户点选路灯位置，程序画路灯时自动为路灯编号

trinco

很有帮助！谢谢lz

cgc

终于看好了，写得很不错， 连我从来不写程序的人都能看得懂了
& t  m6 X0 N* E- E9 G
好好学习，感觉函数 方面还有很多的东西不是很懂
' d" Q( S0 L7 W6 w- W6 k- L8 }; J0 _
6 `3 f! E6 C! w3 C9 i  j; x- W7 F3 |有函数库可以查阅么？
4 }. P$ b$ a0 @4 M2 [
买书也行

nebs

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

lianghn1986

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

pianpi111

auto cad vba第一次听说
学学

nebs

顶！！ 学习中.....

sod11791

太难了，能学会吗？

kyokula

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