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

pengyg1204

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

wangpiwujing

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

yhfsmu

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

设计从零

支持楼主！！！
！

hellmen

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

tianyunxuan

简单地讲，参数化设计就是根据参数进行精确绘图，绘图所需要的参数也可以由用户手工输入。真正的参数化设计往往需要数据库操作，为了简化程序，把数据库部分放在以后的课程中详细讲解。
: c/ @2 u2 q2 I6 @% W; O
3 l1 Q0 v, I, C9 W3 [) q' t5 q    本课的例程是画一个标准足球场。足球场长度90～120米，宽度45～90米，而红色标注的尺寸是程序默认的，绿色标注固定不变。




4 @3 l# i. m3 w5 h, l$ A" NSub court()
Dim courtlay As AcadLayer '定义球场图层
Dim ent As AcadEntity '镜像对象
7 {# M( B7 P3 i4 ?Dim linep1(0 To 2) As Double '线条端点1
Dim linep2(0 To 2) As Double '线条端点2
Dim linep3(0 To 2) As Double '罚球弧端点1
  d. e; s1 }3 T8 ]  B- SDim linep4(0 To 2) As Double '罚球弧端点2
2 ?2 K2 v: K. D5 w/ qDim centerp As Variant '中心坐标
xjq = 11000 '小禁区尺寸
djq = 33000 '大禁区尺寸
. O9 |: r- f( r8 @" a( r4 w1 xfqd = 11000 '罚球点位置
, v% U& \: |  I, f- l6 ufqr = 9150 '罚球弧半径
fqh = 14634.98 '罚球弧弦长
jqqr = 1000 '角球区半径
zqr = 9150 '中圈半径

On Error Resume Next
chang = ThisDrawing.Utility.GetReal("长度(90000～120000)<105000>")
' T2 d8 W6 e( y* FIf Err.Number <> 0 Then '用户输入的不是有效数字
  chang = 105000
  Err.Clear '清除错误
End If
kuan = ThisDrawing.Utility.GetReal("宽度(45000～90000)<68000>")
If Err.Number <> 0 Then
- c7 Y; M2 ^  i6 N  kuan = 68000
End If

8 c+ w& L4 w; J) U5 J4 ], W1 y) [centerp = ThisDrawing.Utility.GetPoint(, "定位球场中心:")

Set courtlay = ThisDrawing.Layers.Add("足球场") '设置图层
ThisDrawing.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) '调用画矩形子程序
0 m4 O  o* Q: M4 w1 z$ ?9 @. }! T
# l* O1 ^) p! ]5 v: k6 N

'画大禁区
) Y' p+ z" w) c: ]" H5 J2 ilinep1(0) = centerp(0) + chang / 2
linep1(1) = centerp(1) + djq / 2
linep2(0) = centerp(0) + chang / 2 - djq / 2
linep2(1) = centerp(1) - djq / 2
) T( D9 z" N. ACall drawbox(linep1, linep2)

4 E# D2 x, {& O: E3 n
& |4 P7 d( O  k' 画罚球点
linep1(0) = centerp(0) + chang / 2 - fqd
linep1(1) = centerp(1)
Call ThisDrawing.ModelSpace.AddPoint(linep1)
5 G* c# u! \6 f5 |'ThisDrawing.SetVariable "PDMODE", 32 '点样式
4 p( ?9 T  L" Z% K( ?/ L0 ~ThisDrawing.SetVariable "PDSIZE", 30 '点的尺寸

'画罚球弧，罚球弧圆心就是罚球点linep1
) H% U0 L$ w% Q2 p' e0 f2 g5 [. Slinep3(0) = centerp(0) + chang / 2 - djq / 2
linep3(1) = centerp(1) + fqh / 2
0 z9 K1 U7 X1 R8 q  k# m2 u# O- ~. dlinep4(0) = linep3(0) '两个端点的x轴相同
8 M. [: v5 ]- ^$ H4 Q" dlinep4(1) = centerp(1) - fqh / 2
ang1 = ThisDrawing.Utility.AngleFromXAxis(linep1, linep3) '计算角度
ang2 = ThisDrawing.Utility.AngleFromXAxis(linep1, linep4)
& U" C$ B5 J2 mCall ThisDrawing.ModelSpace.AddArc(linep1, zqr, ang1, ang2) '画弧
" P5 P1 ^3 d  c$ ]2 }3 R% v

'角球弧
ang1 = ThisDrawing.Utility.AngleToReal(90, 0) '角度转换为弧度
9 B& a4 U7 w/ R) I; Nang2 = ThisDrawing.Utility.AngleToReal(180, 0)
linep1(0) = centerp(0) + chang / 2 '角球弧圆心
* D$ t; I, @9 N. G" b. qlinep1(1) = centerp(1) - kuan / 2
7 ^+ q  f" G; ^8 N* L4 lCall ThisDrawing.ModelSpace.AddArc(linep1, jqqr, ang1, ang2) '画弧
! `5 \, y. X$ U& L! _8 \2 B5 `+ Z8 N
7 E8 G) D5 {& \! k. yang1 = ThisDrawing.Utility.AngleToReal(270, 0)
0 Y* G6 Y1 ~$ [linep1(1) = centerp(1) + kuan / 2
+ _! p* s- I: r+ _: QCall ThisDrawing.ModelSpace.AddArc(linep1, jqqr, ang2, ang1)

" e9 `0 Q' i) t  L
8 m- Q5 \8 ^% |9 v
6 K' Z% R2 f& w: K. N# u8 p1 x+ r4 a'镜像轴
linep1(0) = centerp(0)
linep1(1) = centerp(1) - kuan / 2
linep2(0) = centerp(0)
linep2(1) = centerp(1) + kuan / 2

'镜像
" U' W2 S3 ?# c  U- U" sFor Each ent In ThisDrawing.ModelSpace '所有模型空间的对象进行一次循环
  If ent.Layer = "足球场" Then '对象在"足球场"图层中
    ent.Mirror linep1, linep2 '镜像
" Y4 V% R  m; I3 W- y1 s  End If
Next ent

'画中线
; k7 X! T' I2 WCall ThisDrawing.ModelSpace.AddLine(linep1, linep2)
0 l% A6 s& e  r( Q% h' i
9 R4 K# U/ ]) m9 S( V'画中圈
Call ThisDrawing.ModelSpace.AddCircle(centerp, zqr)
" N0 @3 Z5 L; l" `9 E
'画外框
3 n; u. t! a- Q* @$ ^linep1(0) = centerp(0) - chang / 2
linep1(1) = centerp(1) - kuan / 2
linep2(0) = centerp(0) + chang / 2
linep2(1) = centerp(1) + kuan / 2
Call drawbox(linep1, linep2)
0 O6 T. E3 T# Q( U; c" G4 E, v$ A0 i
3 {& r& b2 y# o8 e- x, a( @ZoomExtents '显示整个图形

# _5 B) d/ t! R& x4 FEnd Sub

Private Sub drawbox(p1, p2) '根据对角线坐标画矩形的子程序
4 k8 y7 ]/ Q9 N7 g6 ADim boxp(0 To 14) As Double
- S% ^( z. v( C- T
: `  }5 T3 H# v' S- Vboxp(0) = p1(0)
boxp(1) = p1(1)
$ D6 _) z  w# O
boxp(3) = p1(0)
boxp(4) = p2(1)
9 Z; y- O9 K( R# B( r+ }( c" }
boxp(6) = p2(0)
5 \2 B% e; Q9 |6 [% n6 ]boxp(7) = p2(1)

boxp(9) = p2(0)
boxp(10) = p1(1)
( M0 U- `, F7 u6 {! J
boxp(12) = p1(0)
boxp(13) = p1(1)

0 b' t1 [6 T$ b% A, xCall ThisDrawing.ModelSpace.AddPolyline(boxp)
: u, y- d9 I7 k4 r. l
9 d* A( @; R* a* Q7 _$ x; vEnd Sub




3 R# v$ \0 A8 s/ r下面开始分析源码：
6 q9 r: h' [3 x" M
- h4 @* l9 L0 \& pOn Error Resume Next
chang = ThisDrawing.Utility.GetReal("长度(90～120)<10500>")
1 ]: w& J4 T- L- j! \* P% IIf Err.Number <> 0 Then '用户输入的不是有效数字
& T! S9 x, l# _chang = 10500
Err.Clear '清除错误
End If
. N: X# F  x" P0 E, u  @  ~
3 F* z/ t9 h$ e, l% ^$ T    这段代码的作用是要求用户输入一个足球场长度的数字，由于getreal只能输入数字，如果输入其他字符程序就会报错，所以先要用去掉错误提示：On Error Resume Next，虽然错误不再提示，但是出错代码会err.number改变，有兴趣的读者可以用变量跟踪的方法看看这个代码的数值。您只要记住，如果这个数字不是0，那么就是有错了，这时就可以把长度定为默认值，然后用Err.Clear语句把错误代码清零。


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

0 u. @7 ?$ k) x  ]( L    Drawbox并不是vba提供的方法，它是一个带参数的子程序。由于画足球场要画好几次矩形，
. d8 K& l& y0 d6 _0 m# C而vba没有提供一个现成的画矩形方法，如果每次都用一长串代码画矩形是很麻烦的，所以需要把这些麻烦的代码写到一个子程序中，在需要时只有写一条调用语句就行了。这个子程序最后几行，从“Private Sub drawbox(p1, p2) ”开始，到end sub结束，p1,p2是参数，调用时也必须写两个参数：linep1、linep2。


ang1 = ThisDrawing.Utility.AngleFromXAxis(linep1, linep3) '计算角度
2 V8 |! |; u* `9 Q% ?/ xang2 = ThisDrawing.Utility.AngleFromXAxis(linep1, linep4)
; i5 A* D& [# l5 O' x6 T' ]Call ThisDrawing.ModelSpace.AddArc(linep1, zqr, ang1, ang2) '画弧

4 T$ U- b  @: P8 A4 f    画圆用addarc方法，需要4个参数：圆心、半径、起始角度、结束角度。AngleFromXAxis用于计算角度，其参数需要两个点坐标
* S* @% o: t. B+ d1 W/ {
下面看镜像操作：
$ r4 [) A( D9 H; R  A# S0 X( [6 JFor Each ent In ThisDrawing.ModelSpace '所有模型空间的对象进行一次循环
) f6 r! P- q$ ]0 s4 O  If ent.Layer = "足球场" Then '对象在"足球场"图层中
1 \  W8 l% Z# C2 Z: k( a    ent.Mirror linep1, linep2 '镜像
, z1 e3 Y: y' z2 o1 l  End If
/ J3 V) Z" t; J6 \1 S% ENext ent

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


4 d" M; h# N8 b0 R8 g+ G本课思考题：

% X: j+ H) C5 `- n0 C0 J; |5 J1、对本课的例程进行修改，当用户输入长、宽不在规定的范围时要求用户重新输入

/ ^' }8 X: J: U; H6 m/ |+ P. y. K* Y4 \2、设计一张简单的平面图，用户输入2个参数，其他尺寸写进程序中
) H* S+ j3 ?+ h! z0 {
[ 本帖最后由 tianyunxuan 于 2007-5-26 20:10 编辑 ]

tianyunxuan

定义块方法：

5 \# d; c% v  k" S4 @0 R6 TSet blocksobj=ThisDrawing.Blocks.Add(基点, 块名)
  o$ a. E) {& \) ?6 W. R把选择集加入块中的方法：
ThisDrawing.CopyObjects(选择集,块)
! q. _5 x; g" E插入块方法：
; |# ^( K$ Q3 ~' q; s& n# t: {ThisDrawing.ModelSpace.InsertBlock(插入点,块名, X轴比例,Y轴比例,Z轴比例, 旋转角度)
画块属性方法：
ThisDrawing.ModelSpace.AddAttribute(文字高度,模式,提示字符, 插入点, 显示字符,默认值)
一共有五种模式，在输入时会有提示，其中最常用的是“acAttributeModeNormal”普通模式
9 j) \: F) c( B- ^2 h
+ i$ T0 x- k1 K9 b4 v5 |$ K0 c4 v% @- w0 c
下面的例题是利用属性块画足球场的阵型图。
% `# L* J% i6 `' y; D程序画出一个球员块，然后把块写到用户指定位置，球员号码由程序自动递增，把球员姓名改为用户输入值。画足球场请参阅上一课内容。
+ o: X; F6 u/ A
: {. i* p- J6 E- x# ?

' k. V" ?( y. [5 ]2 t9 R

' }- v4 I& W# z2 c6 q
编程思路：
1．定义一个空块
2．在块中画一段弧（球服衣领）
3．画多段线，镜像画出球衣
3 G: z# v2 V4 d1 _/ O" w- l4．画块属性，由于块属性默认的对齐方式是左对齐，而球员号码应该居中，所以必须把块的对齐属性改为居中。但是当这个属性更改时块属性对齐点会自动归零，所以不得不再次更改对齐点属性
5．把多段线和属性复制到块中
& a4 I- ]2 _. h6．提示用户点选球员位置和姓名
4 l1 S) m1 ]" a& n2 g# Y7．插入块，修改球衣号码属性、球员姓名属性

, q# J) y8 ^1 [' j& e; @以下是源码，附有详细的注释，如果有疑问，建议用变量跟踪法研究一下。
6 [( I! p0 p( O/ A; ?Sub team()
Dim playerlay As AcadLayer '定义球员图层
Dim playerblock As AcadBlock '定义块变量
- M4 W$ I! K$ gDim arcc(0 To 2) As Double '圆弧圆心
Dim linep1(0 To 2) As Double '线条端点1
Dim linep2(0 To 2) As Double '线条端点2
- k7 Y# w2 X9 ~" \5 d" o. ODim pline(0 To 20) As Double '定义队服右侧多段线7个顶点
, Q$ c/ n# _4 z* X2 A' vDim basep(0 To 2) As Double '块基点
) n$ J1 J- O1 N2 s. c4 l% tDim playernumberpoint(0 To 2) As Double '块属性插入点
Dim mytxt As AcadTextStyle '定义mytxt变量为文本样式
Dim blockRef As AcadBlockReference '定义块属性变量
Dim Attr3 As Variant '插入块属性变量
4 H0 c/ R7 p; K0 E0 T! n
Set playerblock = ThisDrawing.Blocks.Add(basep, "球员") '定义一个"球员"的块

" T1 \- ~, j5 f/ m" d# \arcc(0) = 0
# D# L8 S" p. p# ^, n8 L3 Qarcc(1) = 430
4 L) L! Q7 b: |5 @3 y! z* iCall playerblock.AddArc(arcc, 50, ThisDrawing.Utility.AngleToReal(180, 0), 0) '画弧并加入块中

. G4 Z  c7 \2 N2 ~" |" N+ Opline(0) = 0
pline(1) = 20
5 N+ |7 |' D3 S0 k
& d3 D0 H: Y, g+ `/ @% c$ A4 s% R( ~pline(3) = 100
0 k- z8 p' d6 i) Lpline(4) = 20
/ ^! |& K9 B1 P, K7 J
/ c" H& |1 Q- U/ j8 Q7 Opline(6) = 100
pline(7) = 250

pline(9) = 125
" L  M& e, Z+ ~3 k  E& Z" m' u  Cpline(10) = 207
: T; V# m5 u1 [
, s7 q  `9 z& L8 f  X: kpline(12) = 212
% ~1 m& T- S! \# e* E- r! G0 X! Vpline(13) = 257
& |! j! |; e  _* o7 U# G6 c4 t
- B: R/ W: T: y
7 D, @2 Q8 P# cpline(15) = 112
1 \8 o9 o" ?4 M' w3 y3 {2 kpline(16) = 430


pline(18) = 50
pline(19) = 430
5 h" p3 X% i( E, F4 _2 h
+ R; w- \/ t5 DSet line1 = ThisDrawing.ModelSpace.AddPolyline(pline) '画队服右侧多段线

linep2(1) = 1 '镜像轴第二点位于Y轴上任一点
9 M) _: h0 x8 q+ ^/ {. cSet line2 = line1.Mirror(linep1, linep2) '镜像获得另一半多段线

Dim p(0 To 2) As Double '定义坐标变量
% q1 E' L5 X1 A9 X- S6 dSet mytxt = ThisDrawing.TextStyles.Add("mytxt") '添加mytxt样式
mytxt.fontFile = "c:\windows\fonts\simfang.ttf" '设置字体文件为仿宋体
/ z3 ?5 l2 E& W8 g3 `0 Y) i4 oThisDrawing.ActiveTextStyle = mytxt '将当前文字样式设置为mytxt
! X7 l# Q- ]- [! }" ?0 p+ P& o* j
playernumberpoint(0) = 0 '块属性位置
playernumberpoint(1) = 200
Set attr1 = ThisDrawing.ModelSpace.AddAttribute(100, acAttributeModeNormal, "号码", playernumberpoint, "X", 0) '画块属性
  G- a1 H8 X2 W9 {( D& s+ `attr1.Alignment = 7 '居中
' I/ n* k) x5 N% I% x8 e: u/ a4 d( x4 eattr1.TextAlignmentPoint = playernumberpoint '重定义对齐点
, n& d4 B6 D# b6 |. ^7 y1 rSet attr2 = ThisDrawing.ModelSpace.AddAttribute(100, acAttributeModeNormal, "姓名", playernumberpoint, "???", 0) '画块属性
( T; U# C, e- g# Q' A) y2 X; r* z7 K  Nattr2.Alignment = 7 '居中
0 _0 i# Z; ^! c7 j
) `* c8 M5 F2 e' j7 p1 \- w
% S' H3 h/ A/ u+ q2 k0 f7 E6 UDim objCollection(0 To 3) As Object '创建选择集
Set objCollection(0) = line1 '线条1加入选择集
Set objCollection(1) = line2 '线条2加入选择集
Set objCollection(2) = attr1 '属性1加入选择集
( k- c! Y# v3 H1 R9 n6 gSet objCollection(3) = attr2 '属性2加入选择集

Call ThisDrawing.CopyObjects(objCollection, playerblock) '把选择集加入块中
- S& t) g: P) ?" ^4 y
( ^: D# Z( O8 RFor Each element In objCollection '在选择集中进行循环
. _0 \5 ?! Q: f  u# ^/ m  element.Delete '删除线条和属性(此操作并不影响已创建的块)
Next
  v* Q1 ^9 ~' l# N6 T- M  ]# @+ \
; K! h  z* l6 i3 O
Set playerlay = ThisDrawing.Layers.Add("球员") '新建图层
+ m/ \( m+ |; @3 r- iplayerlay.color = 2 '为黄色
ThisDrawing.ActiveLayer = playerlay '将当前图层设置为球员图层
4 u7 [! q+ b" f' C% i
( z& x, b- e) A& T6 t$ N, C! W; lDim p1 As Variant '块插入点位置
% D3 {  m6 Y6 x( X8 G
For i = 1 To 11 '插入块
1 q: Z2 D! y! R! p  pstring = CStr(i) & "号球员位置："
% i$ x! V$ v3 y# o+ Y2 \, H  p1 = ThisDrawing.Utility.GetPoint(, pstring) '点选球员位置坐标
: G2 X( u6 _% ~4 N  k: x  nstring = ThisDrawing.Utility.GetString(30, "球员姓名：")
  Set blockRef = ThisDrawing.ModelSpace.InsertBlock(p1, "球员", 1, 1, 1, 0) '插入块
  Attr3 = blockRef.GetAttributes '获取块属性
* \/ N* H+ `9 J1 h( }8 T, k! c2 @  Attr3(0).TextString = CStr(i) '赋值球员号码
  Attr3(1).TextString = nstring '赋值球员姓名
/ I; w/ H3 U1 E3 uNext

End Sub

本课思考题：
1、在本课例程的最后一段增加出错陷阱代码，当用户输入非正常数值时退出程序
- {6 J* O) v9 b( r& d2、画一个简易路灯块，用属性块做为路灯编号，由用户点选路灯位置，程序画路灯时自动为路灯编号

trinco

很有帮助！谢谢lz

cgc

终于看好了，写得很不错， 连我从来不写程序的人都能看得懂了
7 _( M) |; d7 G3 Q$ `9 H
! Y7 C/ M5 [3 R+ A' V好好学习，感觉函数 方面还有很多的东西不是很懂
/ a3 T+ J, c. ~2 h) r0 x6 Y
% ]( m# O/ w- u6 m7 k5 ]有函数库可以查阅么？

5 z& i0 f% ]/ u买书也行

nebs

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

lianghn1986

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

pianpi111

auto cad vba第一次听说
# d% W* b$ e- ~5 m学学

nebs

顶！！ 学习中.....

sod11791

太难了，能学会吗？

kyokula

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