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

pengyg1204

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

wangpiwujing

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

yhfsmu

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

设计从零

支持楼主！！！
！

hellmen

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

tianyunxuan

简单地讲，参数化设计就是根据参数进行精确绘图，绘图所需要的参数也可以由用户手工输入。真正的参数化设计往往需要数据库操作，为了简化程序，把数据库部分放在以后的课程中详细讲解。
* G" V1 w" l7 n$ f
    本课的例程是画一个标准足球场。足球场长度90～120米，宽度45～90米，而红色标注的尺寸是程序默认的，绿色标注固定不变。
! F6 G2 n4 a' @


. w  w( ~. n$ |/ f+ e
3 h! t$ e) G) NSub court()
9 Y0 c! q; Y/ \( Y: _7 S8 qDim courtlay As AcadLayer '定义球场图层
Dim ent As AcadEntity '镜像对象
Dim linep1(0 To 2) As Double '线条端点1
Dim linep2(0 To 2) As Double '线条端点2
+ J7 a& [7 d" x: W+ T1 D2 q) B: EDim linep3(0 To 2) As Double '罚球弧端点1
& R+ C0 y' N7 V" i9 E' h: cDim linep4(0 To 2) As Double '罚球弧端点2
Dim centerp As Variant '中心坐标
xjq = 11000 '小禁区尺寸
1 Q# K7 {/ _0 z7 n0 rdjq = 33000 '大禁区尺寸
fqd = 11000 '罚球点位置
$ |! ]1 W8 L& W5 M3 ]) |  ]fqr = 9150 '罚球弧半径
fqh = 14634.98 '罚球弧弦长
jqqr = 1000 '角球区半径
zqr = 9150 '中圈半径

On Error Resume Next
- N( K9 B, @. G, q9 Z- gchang = ThisDrawing.Utility.GetReal("长度(90000～120000)<105000>")
If Err.Number <> 0 Then '用户输入的不是有效数字
  chang = 105000
0 r5 R+ j1 P  \7 n6 y7 u# e' f  Err.Clear '清除错误
End If
8 F6 m. f9 U( ^& ikuan = ThisDrawing.Utility.GetReal("宽度(45000～90000)<68000>")
7 W9 P, p' D$ n4 pIf Err.Number <> 0 Then
2 j, ^5 A( \; V# s' |" R7 y* F  kuan = 68000
& ?0 H7 ?! F0 y6 t$ mEnd If
7 d* Y- t, {  C  K
centerp = ThisDrawing.Utility.GetPoint(, "定位球场中心:")
/ A" R$ T3 `5 u
: k9 x; M" H( O9 J. _Set courtlay = ThisDrawing.Layers.Add("足球场") '设置图层
& G6 ?9 o5 J/ n8 P3 lThisDrawing.ActiveLayer = courtlay '把当前图层设为足球场图层
& t: i# B! E+ V" A# Z$ L/ B
+ b1 p/ \& X1 E5 F8 I'画小禁区
linep1(0) = centerp(0) + chang / 2
linep1(1) = centerp(1) + xjq / 2
7 f7 y: T8 C* _, a- jlinep2(0) = centerp(0) + chang / 2 - xjq / 2
linep2(1) = centerp(1) - xjq / 2
Call drawbox(linep1, linep2) '调用画矩形子程序


  j1 I# K; R, t$ |( ?! t' h2 h
; L! F) k2 O0 Y0 i6 @' |! \'画大禁区
- s4 e- m5 F1 S$ Rlinep1(0) = centerp(0) + chang / 2
linep1(1) = centerp(1) + djq / 2
+ w/ T: ^# k  p. U% j! Y5 K" `1 q% vlinep2(0) = centerp(0) + chang / 2 - djq / 2
linep2(1) = centerp(1) - djq / 2
4 A, I' X7 g  F+ l$ ^: r+ {Call drawbox(linep1, linep2)
% j3 z8 r2 B" f2 B" E/ y* P5 X

0 ]8 g6 @: V  g, b! j' 画罚球点
linep1(0) = centerp(0) + chang / 2 - fqd
linep1(1) = centerp(1)
Call ThisDrawing.ModelSpace.AddPoint(linep1)
# W% @! r" S% U  z6 J. s9 ^'ThisDrawing.SetVariable "PDMODE", 32 '点样式
* X! V7 Y& n6 c- H) I5 IThisDrawing.SetVariable "PDSIZE", 30 '点的尺寸

'画罚球弧，罚球弧圆心就是罚球点linep1
linep3(0) = centerp(0) + chang / 2 - djq / 2
! X, M5 j/ W. b6 T( L% r/ `# p2 D) d3 Llinep3(1) = centerp(1) + fqh / 2
: W1 F* U$ i' }/ j6 r6 Glinep4(0) = linep3(0) '两个端点的x轴相同
7 F! y% E# \; U' O) v1 Ilinep4(1) = centerp(1) - fqh / 2
ang1 = ThisDrawing.Utility.AngleFromXAxis(linep1, linep3) '计算角度
& ^8 P" V) U1 k1 O; [5 @3 Aang2 = ThisDrawing.Utility.AngleFromXAxis(linep1, linep4)
Call ThisDrawing.ModelSpace.AddArc(linep1, zqr, ang1, ang2) '画弧


0 @& E' u( }! D+ |'角球弧
( B- h5 \7 w4 G6 Y  H% B3 o$ s/ sang1 = ThisDrawing.Utility.AngleToReal(90, 0) '角度转换为弧度
4 s& V0 i4 G+ t3 V/ W8 w! @1 x) |5 ~ang2 = ThisDrawing.Utility.AngleToReal(180, 0)
' P9 r/ K) i( b' N' zlinep1(0) = centerp(0) + chang / 2 '角球弧圆心
linep1(1) = centerp(1) - kuan / 2
Call ThisDrawing.ModelSpace.AddArc(linep1, jqqr, ang1, ang2) '画弧
0 G3 N1 c1 r$ g0 i
( E. p; \1 X3 ^& Nang1 = ThisDrawing.Utility.AngleToReal(270, 0)
! Z% x: _/ J/ \linep1(1) = centerp(1) + kuan / 2
! \' o; _& q, J( y& \- M5 {Call ThisDrawing.ModelSpace.AddArc(linep1, jqqr, ang2, ang1)

. O( o$ `* S% s0 m+ b

4 E) j# `0 H4 ^7 v5 H$ b'镜像轴
* n& x1 W% ?, m* Z( Y6 v1 j/ \linep1(0) = centerp(0)
( e! G1 E, [, b5 w3 m( J' klinep1(1) = centerp(1) - kuan / 2
linep2(0) = centerp(0)
linep2(1) = centerp(1) + kuan / 2
3 c! a: T6 n  ^3 F6 N
- [" E% ~& X' e! x' ~'镜像
For Each ent In ThisDrawing.ModelSpace '所有模型空间的对象进行一次循环
  If ent.Layer = "足球场" Then '对象在"足球场"图层中
    ent.Mirror linep1, linep2 '镜像
: I% I7 G4 W$ u& k9 T4 ?) b  End If
Next ent

'画中线
Call ThisDrawing.ModelSpace.AddLine(linep1, linep2)
5 f0 H; J" ^6 c" @, L, g/ U
( t4 m" I: [7 x2 N'画中圈
Call ThisDrawing.ModelSpace.AddCircle(centerp, zqr)
' p5 r2 ?8 G* a' S
* V. W7 r/ }$ c9 v. y( }'画外框
linep1(0) = centerp(0) - chang / 2
linep1(1) = centerp(1) - kuan / 2
$ h) w% A: y+ Z% wlinep2(0) = centerp(0) + chang / 2
linep2(1) = centerp(1) + kuan / 2
/ h: b$ ^" q" ~' F7 x7 dCall drawbox(linep1, linep2)
' X# q# E" P6 ?5 X
" y$ a* f; p( V' OZoomExtents '显示整个图形

4 a$ `' {, n. q8 g/ h5 VEnd Sub

Private Sub drawbox(p1, p2) '根据对角线坐标画矩形的子程序
Dim boxp(0 To 14) As Double
* `/ d+ T2 M1 a9 p0 S7 z
8 Q1 ^. I4 |- b. _8 h  J/ `boxp(0) = p1(0)
% Q* e1 O) e6 ?1 Gboxp(1) = p1(1)
$ T' Y. P0 K( @. W" q6 P$ }
boxp(3) = p1(0)
" h0 ^, ^4 u, d8 ^" W# Eboxp(4) = p2(1)

6 [9 H, y( Q2 c  P/ Jboxp(6) = p2(0)
7 w+ B/ R  @* fboxp(7) = p2(1)
1 a) o3 L  h$ {. y  t) c. i+ n/ }* q
boxp(9) = p2(0)
# \+ R& k2 ?4 m3 Y0 I# n, n6 l( gboxp(10) = p1(1)

boxp(12) = p1(0)
boxp(13) = p1(1)
0 m7 K- K8 u3 m! m/ d& |8 l
Call ThisDrawing.ModelSpace.AddPolyline(boxp)
3 ]7 H2 O! s* g1 t2 [5 u6 ^0 ^
End Sub
  U5 K: ]) W  [& e8 Q7 l9 F

6 i- v" j+ @* y8 t7 a# P# _

( E" Q" k& \3 v- L下面开始分析源码：

+ W% N- J8 B( E/ s2 ]On Error Resume Next
  z8 f) O1 E: y. {' z5 w( p* Tchang = ThisDrawing.Utility.GetReal("长度(90～120)<10500>")
If Err.Number <> 0 Then '用户输入的不是有效数字
) ?: W! |  F$ Y' Fchang = 10500
/ N, {# p6 C5 x+ L2 Y  ~2 rErr.Clear '清除错误
End If
9 N. q' V* q! N& g7 @) D
    这段代码的作用是要求用户输入一个足球场长度的数字，由于getreal只能输入数字，如果输入其他字符程序就会报错，所以先要用去掉错误提示：On Error Resume Next，虽然错误不再提示，但是出错代码会err.number改变，有兴趣的读者可以用变量跟踪的方法看看这个代码的数值。您只要记住，如果这个数字不是0，那么就是有错了，这时就可以把长度定为默认值，然后用Err.Clear语句把错误代码清零。
+ {2 F  Y( V: Z, ^  w4 ~+ W- z% e, R

2 f" P9 a; o' k5 b, s! Y( |$ q    在画小禁区的最后一行这样写：Call drawbox(linep1, linep2)

1 o0 e  K6 w5 j$ g# O( y; [    Drawbox并不是vba提供的方法，它是一个带参数的子程序。由于画足球场要画好几次矩形，
- o( R# U! h& q  B- @; p% W3 |而vba没有提供一个现成的画矩形方法，如果每次都用一长串代码画矩形是很麻烦的，所以需要把这些麻烦的代码写到一个子程序中，在需要时只有写一条调用语句就行了。这个子程序最后几行，从“Private Sub drawbox(p1, p2) ”开始，到end sub结束，p1,p2是参数，调用时也必须写两个参数：linep1、linep2。

6 g4 p! g' D; W2 w# @
ang1 = ThisDrawing.Utility.AngleFromXAxis(linep1, linep3) '计算角度
* S7 t# r4 f: Wang2 = ThisDrawing.Utility.AngleFromXAxis(linep1, linep4)
Call ThisDrawing.ModelSpace.AddArc(linep1, zqr, ang1, ang2) '画弧
, q5 y( a; Z3 S, A
    画圆用addarc方法，需要4个参数：圆心、半径、起始角度、结束角度。AngleFromXAxis用于计算角度，其参数需要两个点坐标
* Q! ?0 N) y: @  N7 S) m' L/ w
6 `% K/ ?; X9 X0 e下面看镜像操作：
  D" _8 Y+ ^1 E# D, g- q3 `For Each ent In ThisDrawing.ModelSpace '所有模型空间的对象进行一次循环
  If ent.Layer = "足球场" Then '对象在"足球场"图层中
! N9 v4 c1 d7 W2 C0 Q( @    ent.Mirror linep1, linep2 '镜像
2 t  B5 v6 z) d) N( z, y6 e  End If
Next ent
% E; d4 h: P3 K  i" p6 y
1 R$ B# y* b4 ^  s4 T; {2 y    本例只对“足球场”图层中的对象进行镜像，所以要对全部对象进行循环，判断对象的图层属性，只有位于“足球场”图层中的对象才作镜像。
1 z3 s9 r( n, U

本课思考题：
/ C4 X9 ]6 ?, q$ K% l5 g; l
9 N% u7 I" [' H0 Q4 m/ }/ x# D& g1、对本课的例程进行修改，当用户输入长、宽不在规定的范围时要求用户重新输入
- z4 V$ I. [4 E4 T+ M7 @. k( d2 W
+ h& V' g: i8 R6 W8 J! f0 t0 D2、设计一张简单的平面图，用户输入2个参数，其他尺寸写进程序中
& y( ]) B! H9 I" }  {* E
2 o* Z2 r5 u/ Y+ I3 E9 V[ 本帖最后由 tianyunxuan 于 2007-5-26 20:10 编辑 ]

tianyunxuan

定义块方法：

Set blocksobj=ThisDrawing.Blocks.Add(基点, 块名)
把选择集加入块中的方法：
0 T1 M/ X* v! V  K: C# ^ThisDrawing.CopyObjects(选择集,块)
' a% J2 X- W9 n/ ?插入块方法：
ThisDrawing.ModelSpace.InsertBlock(插入点,块名, X轴比例,Y轴比例,Z轴比例, 旋转角度)
& a2 A! H2 o# P; J画块属性方法：
5 x8 U0 x0 ]- d; \; w% M  yThisDrawing.ModelSpace.AddAttribute(文字高度,模式,提示字符, 插入点, 显示字符,默认值)
一共有五种模式，在输入时会有提示，其中最常用的是“acAttributeModeNormal”普通模式

3 ?, i$ p+ y+ x% K
下面的例题是利用属性块画足球场的阵型图。
/ |# ~; c& X1 s9 W3 {# T) D程序画出一个球员块，然后把块写到用户指定位置，球员号码由程序自动递增，把球员姓名改为用户输入值。画足球场请参阅上一课内容。

- ~) \, R, ]3 J* e: ]) Y) {% y
. J. M: G+ n+ a' p+ d- t! X

' L. }# I# j0 n! d

9 \5 h/ M" z# S! t0 ?( j编程思路：
1．定义一个空块
, K) z5 ]& g9 l7 _7 D2．在块中画一段弧（球服衣领）
% c3 i, P3 n2 q4 R3．画多段线，镜像画出球衣
4．画块属性，由于块属性默认的对齐方式是左对齐，而球员号码应该居中，所以必须把块的对齐属性改为居中。但是当这个属性更改时块属性对齐点会自动归零，所以不得不再次更改对齐点属性
5．把多段线和属性复制到块中
6．提示用户点选球员位置和姓名
* h4 ~7 `" s/ x& V' X7 h7．插入块，修改球衣号码属性、球员姓名属性

- [/ M6 r' l9 R1 G- s& `1 [以下是源码，附有详细的注释，如果有疑问，建议用变量跟踪法研究一下。
Sub team()
Dim playerlay As AcadLayer '定义球员图层
- W# X1 `# a% ]  ^Dim playerblock As AcadBlock '定义块变量
Dim arcc(0 To 2) As Double '圆弧圆心
% C1 B9 i! _+ KDim linep1(0 To 2) As Double '线条端点1
  N% ]( D. S- _/ s. u, j5 hDim linep2(0 To 2) As Double '线条端点2
4 P/ ~! Q" b) I4 U3 q! }! FDim pline(0 To 20) As Double '定义队服右侧多段线7个顶点
Dim basep(0 To 2) As Double '块基点
+ \6 t; Y/ |& M; g2 Y$ O8 F* u- uDim playernumberpoint(0 To 2) As Double '块属性插入点
5 z: G5 M6 H, \. J; Z" dDim mytxt As AcadTextStyle '定义mytxt变量为文本样式
Dim blockRef As AcadBlockReference '定义块属性变量
/ |2 s; `; ?+ f8 |  D2 c" aDim Attr3 As Variant '插入块属性变量
  l9 x- m0 G' \4 ?" d
Set playerblock = ThisDrawing.Blocks.Add(basep, "球员") '定义一个"球员"的块

arcc(0) = 0
arcc(1) = 430
! U2 v) p2 G& `/ ZCall playerblock.AddArc(arcc, 50, ThisDrawing.Utility.AngleToReal(180, 0), 0) '画弧并加入块中

pline(0) = 0
pline(1) = 20
+ Q9 e3 e* R* l1 s  b' L7 O
pline(3) = 100
# A7 f- N% q( V" E! m$ B- Q/ cpline(4) = 20

pline(6) = 100
pline(7) = 250

pline(9) = 125
- |; |. G  ]8 }0 C0 S6 Npline(10) = 207
. P/ [& S( o) u' U) F, q- b( ?
pline(12) = 212
0 e8 S$ R( t% Q) `+ j1 cpline(13) = 257
$ Y) G% }; a8 e
5 d% @$ B4 M8 A
/ M4 z' C# S$ G5 Wpline(15) = 112
! q. q2 X3 E4 K  ?' d' o  J* Opline(16) = 430


$ r. @# |" b1 k; t' |* E/ Xpline(18) = 50
pline(19) = 430

/ n) \, B$ W1 ~4 G% HSet line1 = ThisDrawing.ModelSpace.AddPolyline(pline) '画队服右侧多段线

linep2(1) = 1 '镜像轴第二点位于Y轴上任一点
) v" B: J, R4 OSet line2 = line1.Mirror(linep1, linep2) '镜像获得另一半多段线
+ A& C1 ]" a+ C: W2 p- ?# N
& ^0 M- W' f" Z9 BDim p(0 To 2) As Double '定义坐标变量
Set mytxt = ThisDrawing.TextStyles.Add("mytxt") '添加mytxt样式
+ z" y: }& W! f! z: k. l1 {mytxt.fontFile = "c:\windows\fonts\simfang.ttf" '设置字体文件为仿宋体
; k, O2 o- _5 q: J. W& rThisDrawing.ActiveTextStyle = mytxt '将当前文字样式设置为mytxt

playernumberpoint(0) = 0 '块属性位置
playernumberpoint(1) = 200
Set attr1 = ThisDrawing.ModelSpace.AddAttribute(100, acAttributeModeNormal, "号码", playernumberpoint, "X", 0) '画块属性
attr1.Alignment = 7 '居中
6 B& Q: F- u4 Cattr1.TextAlignmentPoint = playernumberpoint '重定义对齐点
) ?* W$ N6 o7 Y9 f" G( ]Set attr2 = ThisDrawing.ModelSpace.AddAttribute(100, acAttributeModeNormal, "姓名", playernumberpoint, "???", 0) '画块属性
attr2.Alignment = 7 '居中
7 V; S# P* X. C
7 r# N, U/ h+ a$ F% F$ V( g  Q9 i
& ]$ P5 j+ ?9 ]. f; ?, E1 I: wDim objCollection(0 To 3) As Object '创建选择集
Set objCollection(0) = line1 '线条1加入选择集
Set objCollection(1) = line2 '线条2加入选择集
( _5 s- |7 ?8 b0 A# K4 `Set objCollection(2) = attr1 '属性1加入选择集
Set objCollection(3) = attr2 '属性2加入选择集
5 M) o! A- J" m
Call ThisDrawing.CopyObjects(objCollection, playerblock) '把选择集加入块中

For Each element In objCollection '在选择集中进行循环
" L2 ~) J8 O$ I# ]9 H  element.Delete '删除线条和属性(此操作并不影响已创建的块)
5 N; m2 N  T: m4 ?% A6 f" FNext


6 T; E: a) G: {2 r* B4 BSet playerlay = ThisDrawing.Layers.Add("球员") '新建图层
3 Z, X5 q& j* v% Fplayerlay.color = 2 '为黄色
ThisDrawing.ActiveLayer = playerlay '将当前图层设置为球员图层

Dim p1 As Variant '块插入点位置

For i = 1 To 11 '插入块
  pstring = CStr(i) & "号球员位置："
  p1 = ThisDrawing.Utility.GetPoint(, pstring) '点选球员位置坐标
* j2 t/ O+ l9 D- _: E  nstring = ThisDrawing.Utility.GetString(30, "球员姓名：")
  Set blockRef = ThisDrawing.ModelSpace.InsertBlock(p1, "球员", 1, 1, 1, 0) '插入块
# ~# ]9 M1 X% ^$ u2 }  Attr3 = blockRef.GetAttributes '获取块属性
3 C( `4 B! [- i6 d  Attr3(0).TextString = CStr(i) '赋值球员号码
, B! B; ?6 B9 T  m, v+ F6 m  Attr3(1).TextString = nstring '赋值球员姓名
# D) P( p9 x5 E$ Z; m# r! XNext
2 O% k3 g' N$ c- p
  @3 e# u+ N) W$ c) cEnd Sub
6 \8 T& s2 V7 x, V' t  X
: D* H/ [) V: z) j4 i本课思考题：
2 A$ ~# R3 ?' F7 X. }7 R1、在本课例程的最后一段增加出错陷阱代码，当用户输入非正常数值时退出程序
9 e7 w3 L$ Y- j2、画一个简易路灯块，用属性块做为路灯编号，由用户点选路灯位置，程序画路灯时自动为路灯编号

trinco

很有帮助！谢谢lz

cgc

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

! j: A& \. J% R, D( f! |8 h6 J好好学习，感觉函数 方面还有很多的东西不是很懂
+ C* K7 d% _1 G/ f1 ~
7 a$ z4 a1 P$ t有函数库可以查阅么？

, G( z' ~9 \  N4 Z买书也行

nebs

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

lianghn1986

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

pianpi111

auto cad vba第一次听说
; t1 ]2 R* U3 V- r6 I学学

nebs

顶！！ 学习中.....

sod11791

太难了，能学会吗？

kyokula

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