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

pengyg1204

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

wangpiwujing

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

yhfsmu

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

设计从零

支持楼主！！！
( s+ U) }, V5 ~; L+ K& T！

hellmen

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

tianyunxuan

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

* e9 n& P, o: ^    本课的例程是画一个标准足球场。足球场长度90～120米，宽度45～90米，而红色标注的尺寸是程序默认的，绿色标注固定不变。

! Y  p% \! V/ ]% ]; N0 B
& G6 U; F. e7 o

4 L7 Y/ N; D: G( fSub court()
7 p/ F4 o, a& R. L5 gDim courtlay As AcadLayer '定义球场图层
Dim ent As AcadEntity '镜像对象
, T9 G9 r* D: c) L. iDim linep1(0 To 2) As Double '线条端点1
Dim linep2(0 To 2) As Double '线条端点2
$ e3 B' Z( f9 y# ~5 WDim linep3(0 To 2) As Double '罚球弧端点1
9 d! L* x$ X3 t  @* N  n  MDim linep4(0 To 2) As Double '罚球弧端点2
Dim centerp As Variant '中心坐标
5 h/ s5 _( x5 T$ A8 c8 a8 r7 Q7 zxjq = 11000 '小禁区尺寸
, ]6 _# k, q, W3 {. I' p! Mdjq = 33000 '大禁区尺寸
fqd = 11000 '罚球点位置
8 R. P: j, p9 S8 ^  Pfqr = 9150 '罚球弧半径
1 b; T4 P7 [6 g: E% E8 Xfqh = 14634.98 '罚球弧弦长
jqqr = 1000 '角球区半径
zqr = 9150 '中圈半径
1 z4 b' y; G! g. C8 l8 q
# z" r  e2 ~: e1 ~1 xOn Error Resume Next
1 l; D* [- I; {chang = ThisDrawing.Utility.GetReal("长度(90000～120000)<105000>")
If Err.Number <> 0 Then '用户输入的不是有效数字
3 S  r5 e1 W( Q1 \+ w  chang = 105000
- t- b9 J; Q3 g. W" Y7 z1 I  Err.Clear '清除错误
9 n/ p' _. n: \7 g, T1 R1 W7 I! z2 hEnd If
3 X2 F3 }: j& \kuan = ThisDrawing.Utility.GetReal("宽度(45000～90000)<68000>")
  u& F$ j7 d: eIf Err.Number <> 0 Then
( [6 @: S; P! z% j1 L& b  kuan = 68000
- a& c8 V* x" Q/ m+ Y: rEnd If

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

5 I3 z0 S, F8 P4 B* K; B+ t/ pSet courtlay = ThisDrawing.Layers.Add("足球场") '设置图层
ThisDrawing.ActiveLayer = courtlay '把当前图层设为足球场图层
5 J- P# M& p2 k" F
'画小禁区
7 Z- x/ p9 l" o" N* `7 Olinep1(0) = centerp(0) + chang / 2
# t# D/ y' A0 S$ ?" F4 Vlinep1(1) = centerp(1) + xjq / 2
linep2(0) = centerp(0) + chang / 2 - xjq / 2
5 P, G7 y3 D" Y# w; [$ d. f# L, @linep2(1) = centerp(1) - xjq / 2
7 P, B4 P  X) o+ }Call drawbox(linep1, linep2) '调用画矩形子程序



'画大禁区
. m6 S( Z* c% o; e3 B+ Blinep1(0) = centerp(0) + chang / 2
linep1(1) = centerp(1) + djq / 2
$ N* z6 ~8 |" U: p: Q; M2 Blinep2(0) = centerp(0) + chang / 2 - djq / 2
7 ~. L0 n: U- B9 H8 }1 o) H, llinep2(1) = centerp(1) - djq / 2
4 H  \2 B/ ?$ O. b5 \0 C4 ^Call drawbox(linep1, linep2)


' 画罚球点
linep1(0) = centerp(0) + chang / 2 - fqd
linep1(1) = centerp(1)
Call ThisDrawing.ModelSpace.AddPoint(linep1)
'ThisDrawing.SetVariable "PDMODE", 32 '点样式
6 y! M% X( x% H) P( Q4 q6 D1 CThisDrawing.SetVariable "PDSIZE", 30 '点的尺寸

0 ]0 {3 d# i1 s- o& `  m: h4 j) j/ N'画罚球弧，罚球弧圆心就是罚球点linep1
linep3(0) = centerp(0) + chang / 2 - djq / 2
linep3(1) = centerp(1) + fqh / 2
linep4(0) = linep3(0) '两个端点的x轴相同
" e0 ~3 M! k. q; q& h4 klinep4(1) = centerp(1) - fqh / 2
, B: J; A6 N2 M7 P* jang1 = ThisDrawing.Utility.AngleFromXAxis(linep1, linep3) '计算角度
; F2 n- G; G5 ~# p' f+ {* P/ o9 g" cang2 = ThisDrawing.Utility.AngleFromXAxis(linep1, linep4)
$ w+ I4 R$ w$ j% H. T% mCall ThisDrawing.ModelSpace.AddArc(linep1, zqr, ang1, ang2) '画弧

& a5 Y/ U1 ~0 g6 `- F% s# |+ \
'角球弧
ang1 = ThisDrawing.Utility.AngleToReal(90, 0) '角度转换为弧度
$ T. W. j3 a( P% @- b* Cang2 = ThisDrawing.Utility.AngleToReal(180, 0)
5 y; _  R' N3 m& _+ L1 h+ L8 }3 alinep1(0) = centerp(0) + chang / 2 '角球弧圆心
9 w& q7 T1 r; k, L' ]( vlinep1(1) = centerp(1) - kuan / 2
Call ThisDrawing.ModelSpace.AddArc(linep1, jqqr, ang1, ang2) '画弧

5 @8 o5 p" d* Y- V) [9 i: `) ?, Fang1 = ThisDrawing.Utility.AngleToReal(270, 0)
linep1(1) = centerp(1) + kuan / 2
/ A; z/ V6 q5 F  Z0 E, H% z6 }Call ThisDrawing.ModelSpace.AddArc(linep1, jqqr, ang2, ang1)
; A$ L6 r6 o! m

  k5 l/ w  S2 s4 y9 ?, B6 B
'镜像轴
linep1(0) = centerp(0)
9 b4 H1 h# Q; k0 ~linep1(1) = centerp(1) - kuan / 2
linep2(0) = centerp(0)
3 v3 j% J9 A: b! C( Ylinep2(1) = centerp(1) + kuan / 2

( {" F" g$ {8 x1 r- i! q) ~- Q) a'镜像
, Y4 {% q% o' ~; @! SFor Each ent In ThisDrawing.ModelSpace '所有模型空间的对象进行一次循环
+ ]9 R( C. t& W6 u( V  If ent.Layer = "足球场" Then '对象在"足球场"图层中
    ent.Mirror linep1, linep2 '镜像
  End If
Next ent
3 g+ k. o# T) Z$ r% O& [. n& `' g( L
'画中线
( }$ o% b3 X0 H1 x* xCall ThisDrawing.ModelSpace.AddLine(linep1, linep2)

'画中圈
Call ThisDrawing.ModelSpace.AddCircle(centerp, zqr)
5 x; @( g# a8 ?9 V
1 `$ x/ i$ [4 c'画外框
( r+ {+ x% g3 k3 @. l- {linep1(0) = centerp(0) - chang / 2
1 n; x" D+ U. Elinep1(1) = centerp(1) - kuan / 2
linep2(0) = centerp(0) + chang / 2
linep2(1) = centerp(1) + kuan / 2
. t, m/ X3 K5 z* h+ g4 y6 sCall drawbox(linep1, linep2)
: W& C6 l2 G. @* o/ j' O
2 \9 r( c. ^! ^ZoomExtents '显示整个图形
( |  }) d* _" q6 U
0 j& R5 h5 \% r7 R! p% ^End Sub
" y  v; c1 c7 S) o$ F% B
Private Sub drawbox(p1, p2) '根据对角线坐标画矩形的子程序
Dim boxp(0 To 14) As Double

boxp(0) = p1(0)
- q) m1 }$ |3 K. i' Q" a. |( kboxp(1) = p1(1)
2 n: A& {8 s8 v- B9 p# o7 J8 }
- w! R+ {! ]( ]7 P8 j. Qboxp(3) = p1(0)
# z/ |& M/ @2 `3 H) H+ Y' S/ R) Vboxp(4) = p2(1)
( Y+ l2 r& @5 o$ Y0 g1 M
boxp(6) = p2(0)
0 @; w# R" ~  u$ ?: qboxp(7) = p2(1)

boxp(9) = p2(0)
boxp(10) = p1(1)
6 P- N8 O3 I2 G. v+ ]8 ]3 n7 h7 c
boxp(12) = p1(0)
boxp(13) = p1(1)

% ]- x, {0 p( J) M: g: }. QCall ThisDrawing.ModelSpace.AddPolyline(boxp)
: N  n3 F' d9 f) a& ]" e
End Sub

8 p4 X% A: B: [  `- O: w! n2 f! P

) L! D* W! L+ m1 ~, [. g
下面开始分析源码：

. |  o% r% f! }( C, x, LOn Error Resume Next
8 c7 [4 x5 n& H: `/ q* j2 |6 Xchang = ThisDrawing.Utility.GetReal("长度(90～120)<10500>")
If Err.Number <> 0 Then '用户输入的不是有效数字
chang = 10500
Err.Clear '清除错误
End If

0 o' m. c1 e2 O4 \2 _    这段代码的作用是要求用户输入一个足球场长度的数字，由于getreal只能输入数字，如果输入其他字符程序就会报错，所以先要用去掉错误提示：On Error Resume Next，虽然错误不再提示，但是出错代码会err.number改变，有兴趣的读者可以用变量跟踪的方法看看这个代码的数值。您只要记住，如果这个数字不是0，那么就是有错了，这时就可以把长度定为默认值，然后用Err.Clear语句把错误代码清零。
, j0 E& [0 J- O- h2 u, N4 U
# ?/ r6 V; }- l8 E' |
, S) ^# u0 [1 S: U, q2 S    在画小禁区的最后一行这样写：Call drawbox(linep1, linep2)
- R: z: q" w. d' A* h& V# d
    Drawbox并不是vba提供的方法，它是一个带参数的子程序。由于画足球场要画好几次矩形，
1 O3 \/ h* q  @3 \而vba没有提供一个现成的画矩形方法，如果每次都用一长串代码画矩形是很麻烦的，所以需要把这些麻烦的代码写到一个子程序中，在需要时只有写一条调用语句就行了。这个子程序最后几行，从“Private Sub drawbox(p1, p2) ”开始，到end sub结束，p1,p2是参数，调用时也必须写两个参数：linep1、linep2。


8 S5 ]* X. P3 I. x7 Rang1 = ThisDrawing.Utility.AngleFromXAxis(linep1, linep3) '计算角度
' g4 ?# p) h& oang2 = ThisDrawing.Utility.AngleFromXAxis(linep1, linep4)
Call ThisDrawing.ModelSpace.AddArc(linep1, zqr, ang1, ang2) '画弧

9 G& \4 r0 t/ A2 r7 H% W    画圆用addarc方法，需要4个参数：圆心、半径、起始角度、结束角度。AngleFromXAxis用于计算角度，其参数需要两个点坐标

下面看镜像操作：
For Each ent In ThisDrawing.ModelSpace '所有模型空间的对象进行一次循环
  If ent.Layer = "足球场" Then '对象在"足球场"图层中
    ent.Mirror linep1, linep2 '镜像
  End If
% |% z' V  P& ?+ R7 m; m  JNext ent

5 ~9 Q9 `4 y& g# V5 S3 |    本例只对“足球场”图层中的对象进行镜像，所以要对全部对象进行循环，判断对象的图层属性，只有位于“足球场”图层中的对象才作镜像。


本课思考题：
& p% {0 G4 b# I4 ?7 j
) q# D; D' p  A* Q/ w; O1、对本课的例程进行修改，当用户输入长、宽不在规定的范围时要求用户重新输入

2、设计一张简单的平面图，用户输入2个参数，其他尺寸写进程序中

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

tianyunxuan

定义块方法：

Set blocksobj=ThisDrawing.Blocks.Add(基点, 块名)
把选择集加入块中的方法：
8 W+ }7 U& c% J2 q; |# fThisDrawing.CopyObjects(选择集,块)
2 t3 v9 c  k0 J. }' T( K插入块方法：
ThisDrawing.ModelSpace.InsertBlock(插入点,块名, X轴比例,Y轴比例,Z轴比例, 旋转角度)
画块属性方法：
ThisDrawing.ModelSpace.AddAttribute(文字高度,模式,提示字符, 插入点, 显示字符,默认值)
一共有五种模式，在输入时会有提示，其中最常用的是“acAttributeModeNormal”普通模式

' c+ c7 W7 f+ ?' s) H- {5 @9 D0 x
! h- k- O7 q3 ?& P  B8 j下面的例题是利用属性块画足球场的阵型图。
# N/ @& U8 d$ P程序画出一个球员块，然后把块写到用户指定位置，球员号码由程序自动递增，把球员姓名改为用户输入值。画足球场请参阅上一课内容。
! Y: v6 Y# L7 D1 S: b; S( ~
4 v4 O  i' ^. K/ e' e2 ~
- {9 `3 @! Y+ T8 g) f

3 F3 Q# z1 w" |' I3 J
% ~4 J5 y$ I- T  j
% \, W# D% `8 w) t/ i编程思路：
1．定义一个空块
2．在块中画一段弧（球服衣领）
3．画多段线，镜像画出球衣
4．画块属性，由于块属性默认的对齐方式是左对齐，而球员号码应该居中，所以必须把块的对齐属性改为居中。但是当这个属性更改时块属性对齐点会自动归零，所以不得不再次更改对齐点属性
9 l( U; Y3 T; v5．把多段线和属性复制到块中
0 a2 \# [1 Z5 U. M6 R6．提示用户点选球员位置和姓名
% p7 q7 q% O! A- g. `  U7．插入块，修改球衣号码属性、球员姓名属性

: d) M: ?8 {9 ?( k9 p; P3 v以下是源码，附有详细的注释，如果有疑问，建议用变量跟踪法研究一下。
Sub team()
& F: g; [' E* r: R9 K6 pDim playerlay As AcadLayer '定义球员图层
. g# c# d# U' K$ iDim playerblock As AcadBlock '定义块变量
Dim arcc(0 To 2) As Double '圆弧圆心
# k3 a1 W2 z3 X7 w& x! [- t" KDim linep1(0 To 2) As Double '线条端点1
Dim linep2(0 To 2) As Double '线条端点2
Dim pline(0 To 20) As Double '定义队服右侧多段线7个顶点
, v, B1 _' }+ K& e$ F0 sDim basep(0 To 2) As Double '块基点
/ \5 ]4 U" O* H+ L3 d) WDim playernumberpoint(0 To 2) As Double '块属性插入点
Dim mytxt As AcadTextStyle '定义mytxt变量为文本样式
Dim blockRef As AcadBlockReference '定义块属性变量
Dim Attr3 As Variant '插入块属性变量

3 L8 f+ @9 O5 h/ p, K8 j( o4 D( ?Set playerblock = ThisDrawing.Blocks.Add(basep, "球员") '定义一个"球员"的块
% _: ^' |' y' z4 R/ }
/ Z. i- `( A$ \; }% ?" tarcc(0) = 0
  o9 f; M+ I: u5 R6 S  larcc(1) = 430
Call playerblock.AddArc(arcc, 50, ThisDrawing.Utility.AngleToReal(180, 0), 0) '画弧并加入块中
# U  U5 k1 Q5 G/ o2 q3 w
pline(0) = 0
pline(1) = 20
# C& c. d- h1 X# J0 f
8 |5 ~# ]# V: mpline(3) = 100
pline(4) = 20

% |" Y% C; Y2 k8 [1 Wpline(6) = 100
pline(7) = 250
) x" `! g2 h9 b4 u. ?- U, k9 ?
$ p( C: B' S% opline(9) = 125
pline(10) = 207
% d" S* K6 C5 x# d
pline(12) = 212
3 j# N/ n9 W! w+ S  fpline(13) = 257


3 b- F5 |5 l! A8 R5 c' J$ X) upline(15) = 112
pline(16) = 430
  }: S- H$ i: X' h

& h5 |% X$ c  ]. \pline(18) = 50
$ P4 n& Y7 `! ^( Jpline(19) = 430

  Q0 K5 l' K5 u  Y" W% ~' \% BSet line1 = ThisDrawing.ModelSpace.AddPolyline(pline) '画队服右侧多段线

linep2(1) = 1 '镜像轴第二点位于Y轴上任一点
Set line2 = line1.Mirror(linep1, linep2) '镜像获得另一半多段线
7 y1 Y2 b5 X0 C/ u6 E5 P( W: {! b1 C0 J
Dim p(0 To 2) As Double '定义坐标变量
Set mytxt = ThisDrawing.TextStyles.Add("mytxt") '添加mytxt样式
mytxt.fontFile = "c:\windows\fonts\simfang.ttf" '设置字体文件为仿宋体
ThisDrawing.ActiveTextStyle = mytxt '将当前文字样式设置为mytxt

$ }% F+ l! I8 {5 U7 n" a8 l# {6 Jplayernumberpoint(0) = 0 '块属性位置
, r- h1 c$ e* i. B  L) O. i9 e+ h4 dplayernumberpoint(1) = 200
Set attr1 = ThisDrawing.ModelSpace.AddAttribute(100, acAttributeModeNormal, "号码", playernumberpoint, "X", 0) '画块属性
attr1.Alignment = 7 '居中
attr1.TextAlignmentPoint = playernumberpoint '重定义对齐点
5 p$ h% k& l8 h* ySet attr2 = ThisDrawing.ModelSpace.AddAttribute(100, acAttributeModeNormal, "姓名", playernumberpoint, "???", 0) '画块属性
attr2.Alignment = 7 '居中
7 h) j/ i; Z3 f
' a' _: D  g7 O! c0 ~& m& b
Dim objCollection(0 To 3) As Object '创建选择集
Set objCollection(0) = line1 '线条1加入选择集
2 |" V: T; T8 _0 K" U& vSet objCollection(1) = line2 '线条2加入选择集
Set objCollection(2) = attr1 '属性1加入选择集
' I+ t. ^. h, f. fSet objCollection(3) = attr2 '属性2加入选择集

& M2 i1 i6 X9 i+ k* sCall ThisDrawing.CopyObjects(objCollection, playerblock) '把选择集加入块中

For Each element In objCollection '在选择集中进行循环
8 D1 e* ~8 ]; b9 {  A" h  element.Delete '删除线条和属性(此操作并不影响已创建的块)
6 t' r1 X( q& YNext


Set playerlay = ThisDrawing.Layers.Add("球员") '新建图层
% C& ~$ h: v; r4 v/ Z# e0 hplayerlay.color = 2 '为黄色
ThisDrawing.ActiveLayer = playerlay '将当前图层设置为球员图层
$ q9 m, Q% a4 P3 L2 \/ }
2 v; o# j8 Z; `) x$ H# Z. eDim p1 As Variant '块插入点位置
( |0 o/ p4 P! A# M/ i/ `! n
For i = 1 To 11 '插入块
  pstring = CStr(i) & "号球员位置："
  p1 = ThisDrawing.Utility.GetPoint(, pstring) '点选球员位置坐标
  nstring = ThisDrawing.Utility.GetString(30, "球员姓名：")
  Set blockRef = ThisDrawing.ModelSpace.InsertBlock(p1, "球员", 1, 1, 1, 0) '插入块
  Attr3 = blockRef.GetAttributes '获取块属性
! d; @: _4 f) m, M  Attr3(0).TextString = CStr(i) '赋值球员号码
  Attr3(1).TextString = nstring '赋值球员姓名
Next

" B1 D; r& U( d5 cEnd Sub
0 c! h5 o5 o5 r1 H4 }
% c+ [  {, \9 n# R! a3 _本课思考题：
5 n) o0 _: {- O1 A. Z, k1、在本课例程的最后一段增加出错陷阱代码，当用户输入非正常数值时退出程序
2、画一个简易路灯块，用属性块做为路灯编号，由用户点选路灯位置，程序画路灯时自动为路灯编号

trinco

很有帮助！谢谢lz

cgc

终于看好了，写得很不错， 连我从来不写程序的人都能看得懂了
$ B* R+ ~: y% m4 `2 q3 Z/ w! Z
好好学习，感觉函数 方面还有很多的东西不是很懂
+ B4 o3 @/ |, e# Z; C
有函数库可以查阅么？

* t" z# \: r# Y8 f买书也行

nebs

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

lianghn1986

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

pianpi111

auto cad vba第一次听说
: H% g& T( U: e  n学学

nebs

顶！！ 学习中.....

sod11791

太难了，能学会吗？

kyokula

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