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

pengyg1204

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

wangpiwujing

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

yhfsmu

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

设计从零

支持楼主！！！
！

hellmen

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

tianyunxuan

简单地讲，参数化设计就是根据参数进行精确绘图，绘图所需要的参数也可以由用户手工输入。真正的参数化设计往往需要数据库操作，为了简化程序，把数据库部分放在以后的课程中详细讲解。
" Z6 w! D8 C( g6 t* ?, E; ]
2 Y3 D, t. j+ L) K    本课的例程是画一个标准足球场。足球场长度90～120米，宽度45～90米，而红色标注的尺寸是程序默认的，绿色标注固定不变。


! e, Q# ], |6 _, r4 o: C- ]# \) W
" l5 \# P; C2 H4 y
Sub court()
Dim courtlay As AcadLayer '定义球场图层
+ N+ J; {9 h  P4 s& O8 G6 @Dim ent As AcadEntity '镜像对象
Dim linep1(0 To 2) As Double '线条端点1
& N: x. }$ n( k0 d% i( o( sDim linep2(0 To 2) As Double '线条端点2
6 f  Y( T4 [* b; U9 o9 W. _$ jDim linep3(0 To 2) As Double '罚球弧端点1
Dim linep4(0 To 2) As Double '罚球弧端点2
0 R5 T" M* h/ _8 K! K) v4 aDim centerp As Variant '中心坐标
xjq = 11000 '小禁区尺寸
djq = 33000 '大禁区尺寸
fqd = 11000 '罚球点位置
fqr = 9150 '罚球弧半径
fqh = 14634.98 '罚球弧弦长
) p4 x; w1 S' I$ ajqqr = 1000 '角球区半径
* @4 m) V' ~' u7 Z. ezqr = 9150 '中圈半径

7 }/ }( ~3 n3 W7 m& `9 [0 E2 l: jOn Error Resume Next
2 }/ t2 i! w" b, q/ x. u" Kchang = ThisDrawing.Utility.GetReal("长度(90000～120000)<105000>")
If Err.Number <> 0 Then '用户输入的不是有效数字
  chang = 105000
7 Z# y. C2 k1 B% ~, o  Err.Clear '清除错误
8 ]4 \: i% u% d5 A! VEnd If
& `- Q) N% {: C: q) j( Akuan = ThisDrawing.Utility.GetReal("宽度(45000～90000)<68000>")
If Err.Number <> 0 Then
  kuan = 68000
0 q, v8 p/ a) K) P% eEnd If
2 W: G3 q) N& O6 Z+ d& }& k
centerp = ThisDrawing.Utility.GetPoint(, "定位球场中心:")
- z( w, z, i7 v
Set courtlay = ThisDrawing.Layers.Add("足球场") '设置图层
1 y( b7 v! W1 [# G- i# l$ vThisDrawing.ActiveLayer = courtlay '把当前图层设为足球场图层
* c% u  M- Y* ?7 |* c( H, N" l$ J2 O$ G: u
'画小禁区
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) '调用画矩形子程序
) \5 K8 @. E/ ~( o0 k
/ ]0 P$ E" o4 O: [
+ p( `4 [% l1 Y
'画大禁区
' Y) G8 _1 M# h9 clinep1(0) = centerp(0) + chang / 2
0 {5 p& P+ E' z# V& ylinep1(1) = centerp(1) + djq / 2
1 v8 m5 {9 |  ilinep2(0) = centerp(0) + chang / 2 - djq / 2
linep2(1) = centerp(1) - djq / 2
Call drawbox(linep1, linep2)


. g, A$ B0 ^* [- C' 画罚球点
6 H* @9 D8 T  ~% L' F  ilinep1(0) = centerp(0) + chang / 2 - fqd
linep1(1) = centerp(1)
% Q8 M8 \! W  x) }Call ThisDrawing.ModelSpace.AddPoint(linep1)
4 Z4 t4 L, _7 u'ThisDrawing.SetVariable "PDMODE", 32 '点样式
ThisDrawing.SetVariable "PDSIZE", 30 '点的尺寸

8 u, [3 a4 s& ^# w'画罚球弧，罚球弧圆心就是罚球点linep1
linep3(0) = centerp(0) + chang / 2 - djq / 2
linep3(1) = centerp(1) + fqh / 2
linep4(0) = linep3(0) '两个端点的x轴相同
1 C: f& H6 L- |) c; j* Q/ _& rlinep4(1) = centerp(1) - fqh / 2
  j! I, U9 \. Qang1 = ThisDrawing.Utility.AngleFromXAxis(linep1, linep3) '计算角度
1 B" ^; W1 u/ _( Sang2 = ThisDrawing.Utility.AngleFromXAxis(linep1, linep4)
Call ThisDrawing.ModelSpace.AddArc(linep1, zqr, ang1, ang2) '画弧
/ ]' F' w" j% v6 S- g
$ ?5 ?+ U+ |& b& N9 c
* A+ c! |5 w$ p' ?) a3 G0 N'角球弧
8 M. l& I! `- r7 g1 fang1 = ThisDrawing.Utility.AngleToReal(90, 0) '角度转换为弧度
ang2 = ThisDrawing.Utility.AngleToReal(180, 0)
linep1(0) = centerp(0) + chang / 2 '角球弧圆心
  [' q$ F" b% \. i9 T; Flinep1(1) = centerp(1) - kuan / 2
Call ThisDrawing.ModelSpace.AddArc(linep1, jqqr, ang1, ang2) '画弧

ang1 = ThisDrawing.Utility.AngleToReal(270, 0)
9 s% v0 S8 P+ d5 Tlinep1(1) = centerp(1) + kuan / 2
6 }3 O5 D' r3 K$ d( k; hCall ThisDrawing.ModelSpace.AddArc(linep1, jqqr, ang2, ang1)



'镜像轴
linep1(0) = centerp(0)
& R  r2 l5 B6 n0 qlinep1(1) = centerp(1) - kuan / 2
linep2(0) = centerp(0)
. `$ W  |# Y, n2 B! i0 Jlinep2(1) = centerp(1) + kuan / 2
$ v; P  b/ ]2 i2 d1 K- U
8 X" m, n$ r! m9 h8 ], J: y  h! _' v'镜像
For Each ent In ThisDrawing.ModelSpace '所有模型空间的对象进行一次循环
  If ent.Layer = "足球场" Then '对象在"足球场"图层中
    ent.Mirror linep1, linep2 '镜像
  End If
Next ent

'画中线
. E4 P) D& i- e" e1 W1 bCall ThisDrawing.ModelSpace.AddLine(linep1, linep2)
0 Y  c8 B5 \5 {- ?# z( @
'画中圈
; R6 R0 e, ^1 T- e8 I) `& h, hCall ThisDrawing.ModelSpace.AddCircle(centerp, zqr)
, w% i+ d. U: d; O
: e, ^* h0 p) U9 c5 M'画外框
. F5 l; l/ i% alinep1(0) = centerp(0) - chang / 2
7 }6 B& l2 S. Q* qlinep1(1) = centerp(1) - kuan / 2
linep2(0) = centerp(0) + chang / 2
% p0 p; A$ d3 y9 ~8 P* A* xlinep2(1) = centerp(1) + kuan / 2
! ]: }7 j/ ~7 D$ fCall drawbox(linep1, linep2)

ZoomExtents '显示整个图形

) I% u5 t6 B' k/ jEnd Sub
# V! F# u: M' i2 a+ t0 J9 R7 E
2 G1 @6 `4 s. U- J9 p$ L: ?7 X' x2 }Private Sub drawbox(p1, p2) '根据对角线坐标画矩形的子程序
9 h  p" i/ g0 @8 UDim boxp(0 To 14) As Double
! i8 k7 M/ J1 a; \9 Q7 \
boxp(0) = p1(0)
boxp(1) = p1(1)
. a6 w1 W, E0 D, Z) U. X/ D7 V( @
boxp(3) = p1(0)
6 C- f! t5 q1 m& b9 S; sboxp(4) = p2(1)
: Y! ?* Y% \  Q' j/ {7 D
boxp(6) = p2(0)
boxp(7) = p2(1)

  j# U  W3 P3 d4 a* H( @# T1 fboxp(9) = p2(0)
boxp(10) = p1(1)

- H' L) J) u+ j* F; gboxp(12) = p1(0)
$ `2 I1 h& M9 ]9 U) W# iboxp(13) = p1(1)

/ T8 v7 D6 M% Y; k/ a, nCall ThisDrawing.ModelSpace.AddPolyline(boxp)

End Sub
2 J. w8 r3 |6 T

  L) g' o. Q) n; X0 N  I% M3 A( x5 L
- `( u, N* L; G# [
4 v0 }* O! J3 }* l- M5 j8 U下面开始分析源码：

0 t% |5 T1 z! W1 M" TOn Error Resume Next
chang = ThisDrawing.Utility.GetReal("长度(90～120)<10500>")
If Err.Number <> 0 Then '用户输入的不是有效数字
chang = 10500
Err.Clear '清除错误
End If
& S# F' y; S5 Y7 F5 _
    这段代码的作用是要求用户输入一个足球场长度的数字，由于getreal只能输入数字，如果输入其他字符程序就会报错，所以先要用去掉错误提示：On Error Resume Next，虽然错误不再提示，但是出错代码会err.number改变，有兴趣的读者可以用变量跟踪的方法看看这个代码的数值。您只要记住，如果这个数字不是0，那么就是有错了，这时就可以把长度定为默认值，然后用Err.Clear语句把错误代码清零。


    在画小禁区的最后一行这样写：Call drawbox(linep1, linep2)
5 k, I, H$ i) z$ J8 C* b4 g- ?
    Drawbox并不是vba提供的方法，它是一个带参数的子程序。由于画足球场要画好几次矩形，
而vba没有提供一个现成的画矩形方法，如果每次都用一长串代码画矩形是很麻烦的，所以需要把这些麻烦的代码写到一个子程序中，在需要时只有写一条调用语句就行了。这个子程序最后几行，从“Private Sub drawbox(p1, p2) ”开始，到end sub结束，p1,p2是参数，调用时也必须写两个参数：linep1、linep2。
7 ?* D5 e+ C; U7 ?0 W! R5 M: T
3 j. k1 g9 g: N5 Q6 {$ O% z  a
ang1 = ThisDrawing.Utility.AngleFromXAxis(linep1, linep3) '计算角度
ang2 = ThisDrawing.Utility.AngleFromXAxis(linep1, linep4)
Call ThisDrawing.ModelSpace.AddArc(linep1, zqr, ang1, ang2) '画弧
9 n& p) f2 E, f! \( O
    画圆用addarc方法，需要4个参数：圆心、半径、起始角度、结束角度。AngleFromXAxis用于计算角度，其参数需要两个点坐标

- ?* @# m$ o( a8 A) ~$ s& m' a( a/ H下面看镜像操作：
2 n7 {6 E4 h# S1 `# zFor Each ent In ThisDrawing.ModelSpace '所有模型空间的对象进行一次循环
, {" K0 K" E) J# A& `  If ent.Layer = "足球场" Then '对象在"足球场"图层中
    ent.Mirror linep1, linep2 '镜像
7 Y6 p3 Z/ h; a2 {1 ]6 {% M  End If
; p4 }0 |4 x( P" e9 \, s: `9 d" l# _Next ent

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

$ {2 \; u! V! S+ w' Z
" K' r' U; M" A; V+ O) Q本课思考题：

1、对本课的例程进行修改，当用户输入长、宽不在规定的范围时要求用户重新输入
; T$ |* n1 J3 M0 g6 L: \
2、设计一张简单的平面图，用户输入2个参数，其他尺寸写进程序中

- k' P4 @# |6 a5 e: k[ 本帖最后由 tianyunxuan 于 2007-5-26 20:10 编辑 ]

tianyunxuan

定义块方法：
/ I0 @% `* z, ~( b* i, J
( W# E# A* H7 B! z. XSet blocksobj=ThisDrawing.Blocks.Add(基点, 块名)
1 c& r" V4 v2 {$ q( s0 l4 I把选择集加入块中的方法：
2 K; G) _# i! D% QThisDrawing.CopyObjects(选择集,块)
1 u( G$ F. a) b0 H插入块方法：
ThisDrawing.ModelSpace.InsertBlock(插入点,块名, X轴比例,Y轴比例,Z轴比例, 旋转角度)
画块属性方法：
ThisDrawing.ModelSpace.AddAttribute(文字高度,模式,提示字符, 插入点, 显示字符,默认值)
1 Z/ h3 `: X0 G1 B' m% ~9 S一共有五种模式，在输入时会有提示，其中最常用的是“acAttributeModeNormal”普通模式

8 \7 u5 A/ S+ y2 z
下面的例题是利用属性块画足球场的阵型图。
程序画出一个球员块，然后把块写到用户指定位置，球员号码由程序自动递增，把球员姓名改为用户输入值。画足球场请参阅上一课内容。
8 [6 u3 J) a2 z& u0 y/ {

8 [- |" s7 W, S9 g( _2 w# b
8 o0 s/ i' Y5 g% {8 Q( Y5 g5 o- X
  b% Y; x! e; w7 R% p5 o1 ?
# B, G/ H$ A- ]3 h" J
编程思路：
1．定义一个空块
2 [% j8 x# ?5 z4 a2．在块中画一段弧（球服衣领）
! L9 s. I% t2 t' s8 @3．画多段线，镜像画出球衣
* h9 x1 E! W- V) o4．画块属性，由于块属性默认的对齐方式是左对齐，而球员号码应该居中，所以必须把块的对齐属性改为居中。但是当这个属性更改时块属性对齐点会自动归零，所以不得不再次更改对齐点属性
' a& \# o1 f3 S! h( C! j5．把多段线和属性复制到块中
6．提示用户点选球员位置和姓名
: d, y2 g: M, S2 x+ {# w0 w7．插入块，修改球衣号码属性、球员姓名属性

; e; Y* B- j7 p0 E5 w以下是源码，附有详细的注释，如果有疑问，建议用变量跟踪法研究一下。
- I! j+ J2 k+ i$ E: hSub team()
6 u& z$ X7 F8 s4 l8 f* W5 m: @0 LDim playerlay As AcadLayer '定义球员图层
Dim playerblock As AcadBlock '定义块变量
Dim arcc(0 To 2) As Double '圆弧圆心
7 @4 ^0 z$ ^( T  m' IDim linep1(0 To 2) As Double '线条端点1
Dim linep2(0 To 2) As Double '线条端点2
Dim pline(0 To 20) As Double '定义队服右侧多段线7个顶点
1 G3 x- l$ R& ~" [8 I6 m1 V( f0 IDim basep(0 To 2) As Double '块基点
. D4 V$ e, P+ z6 P( S$ k8 VDim playernumberpoint(0 To 2) As Double '块属性插入点
# r- L% M! G2 X% p' o: iDim mytxt As AcadTextStyle '定义mytxt变量为文本样式
Dim blockRef As AcadBlockReference '定义块属性变量
Dim Attr3 As Variant '插入块属性变量

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

; Q9 m# v1 Z% a8 L: I2 b- O; J6 carcc(0) = 0
arcc(1) = 430
# ^/ L% f& \: O" ~Call playerblock.AddArc(arcc, 50, ThisDrawing.Utility.AngleToReal(180, 0), 0) '画弧并加入块中

3 z4 E6 S2 Z) [( ?* Y; Ypline(0) = 0
pline(1) = 20

pline(3) = 100
. n% A3 L) V  o) N: f8 z' y) Jpline(4) = 20

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

* b7 j/ b2 S1 N" G% j1 qpline(9) = 125
5 \& W: }: Q9 U: G' wpline(10) = 207
# p! }; \# j. U/ m' z) ~
pline(12) = 212
pline(13) = 257

) W9 p9 ]% K6 z$ J6 K
% R* Z% u& j  t+ y  F) B8 B; Rpline(15) = 112
pline(16) = 430


( a- F% Z1 \* c" @  xpline(18) = 50
( y4 C, Y; d: d0 n  E, }; c% Z9 M# xpline(19) = 430

Set line1 = ThisDrawing.ModelSpace.AddPolyline(pline) '画队服右侧多段线
) w: C1 |# L2 i
/ b; j% f+ Y* ?' f4 A( t! c# J: Rlinep2(1) = 1 '镜像轴第二点位于Y轴上任一点
Set line2 = line1.Mirror(linep1, linep2) '镜像获得另一半多段线

. J3 S1 [( N, }2 ^" [& `2 o( F& ]% {Dim p(0 To 2) As Double '定义坐标变量
Set mytxt = ThisDrawing.TextStyles.Add("mytxt") '添加mytxt样式
2 O' D6 a- L% @! \$ p; }mytxt.fontFile = "c:\windows\fonts\simfang.ttf" '设置字体文件为仿宋体
' a) L6 w% H$ l. E$ H" {ThisDrawing.ActiveTextStyle = mytxt '将当前文字样式设置为mytxt

' S! M, n/ d1 R8 L( U- t8 {, {playernumberpoint(0) = 0 '块属性位置
7 p1 I3 Q* p3 N! {% c6 Lplayernumberpoint(1) = 200
# t1 N4 {% N# M9 YSet attr1 = ThisDrawing.ModelSpace.AddAttribute(100, acAttributeModeNormal, "号码", playernumberpoint, "X", 0) '画块属性
# E5 |. H) N( k, k! x6 o1 v) ]attr1.Alignment = 7 '居中
4 M2 x- ], ~, P) h& D( dattr1.TextAlignmentPoint = playernumberpoint '重定义对齐点
2 V- V: v0 w2 t8 E: ~Set attr2 = ThisDrawing.ModelSpace.AddAttribute(100, acAttributeModeNormal, "姓名", playernumberpoint, "???", 0) '画块属性
attr2.Alignment = 7 '居中


Dim objCollection(0 To 3) As Object '创建选择集
6 q" h; X( E9 X8 W9 X; d, PSet objCollection(0) = line1 '线条1加入选择集
  L# @8 r5 m. f; ySet objCollection(1) = line2 '线条2加入选择集
Set objCollection(2) = attr1 '属性1加入选择集
Set objCollection(3) = attr2 '属性2加入选择集

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

For Each element In objCollection '在选择集中进行循环
  element.Delete '删除线条和属性(此操作并不影响已创建的块)
% B2 |$ x* g% p, z% _5 ~+ ~  nNext


2 I( c, `) f5 g2 y, _  E5 ySet playerlay = ThisDrawing.Layers.Add("球员") '新建图层
! o( l4 O5 N* D! b: R( Y( j2 Q2 hplayerlay.color = 2 '为黄色
ThisDrawing.ActiveLayer = playerlay '将当前图层设置为球员图层

! n5 G7 g8 o0 U& I6 p. s( GDim p1 As Variant '块插入点位置

For i = 1 To 11 '插入块
( ~4 G% V5 L2 \2 b! b  pstring = CStr(i) & "号球员位置："
4 g5 s3 O& ~1 @- v  e( J; k  p1 = ThisDrawing.Utility.GetPoint(, pstring) '点选球员位置坐标
; ?8 A+ `! K, U  nstring = ThisDrawing.Utility.GetString(30, "球员姓名：")
  Set blockRef = ThisDrawing.ModelSpace.InsertBlock(p1, "球员", 1, 1, 1, 0) '插入块
( Q  T& K& Q/ r* c( e  Attr3 = blockRef.GetAttributes '获取块属性
5 Z; L% n# |" t8 k  Attr3(0).TextString = CStr(i) '赋值球员号码
5 r  T9 m8 P+ b2 F  Attr3(1).TextString = nstring '赋值球员姓名
Next
$ `( _8 u# K! F$ Q9 x
End Sub

本课思考题：
2 H& F* \7 M( k5 k6 r$ H4 n1、在本课例程的最后一段增加出错陷阱代码，当用户输入非正常数值时退出程序
2、画一个简易路灯块，用属性块做为路灯编号，由用户点选路灯位置，程序画路灯时自动为路灯编号

trinco

很有帮助！谢谢lz

cgc

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

; t9 d2 e# \, B/ i% Y好好学习，感觉函数 方面还有很多的东西不是很懂
+ w. {8 q  d# s% s8 s; y  f
有函数库可以查阅么？

( d0 W, k/ O: c# {买书也行

nebs

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

lianghn1986

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

pianpi111

auto cad vba第一次听说
学学

nebs

顶！！ 学习中.....

sod11791

太难了，能学会吗？

kyokula

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