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

pengyg1204

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

wangpiwujing

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

yhfsmu

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

设计从零

支持楼主！！！
# k5 |, z  x+ @1 t/ V: N. W- _$ @& H！

hellmen

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

tianyunxuan

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

% S% M2 L" R/ n1 E" b0 ?+ f    本课的例程是画一个标准足球场。足球场长度90～120米，宽度45～90米，而红色标注的尺寸是程序默认的，绿色标注固定不变。
3 y8 _7 J2 E% H

- H7 P/ K6 |9 j9 y$ m+ o

Sub court()
Dim courtlay As AcadLayer '定义球场图层
Dim ent As AcadEntity '镜像对象
$ f; M- p% v* u" l( }7 S6 BDim linep1(0 To 2) As Double '线条端点1
Dim linep2(0 To 2) As Double '线条端点2
Dim linep3(0 To 2) As Double '罚球弧端点1
. k1 |8 _! F1 P! b5 D, T; QDim linep4(0 To 2) As Double '罚球弧端点2
" p( u" O! f, |$ Y1 ~' H7 E# i) O, X% [Dim centerp As Variant '中心坐标
& `( s, {6 C' c' wxjq = 11000 '小禁区尺寸
+ N8 ^+ l* p6 t* s9 Qdjq = 33000 '大禁区尺寸
& t  H1 q3 r: W4 N0 k& E. sfqd = 11000 '罚球点位置
) `9 |/ [1 P8 {/ h1 P0 e6 efqr = 9150 '罚球弧半径
& u3 b4 @8 K# }# ~fqh = 14634.98 '罚球弧弦长
jqqr = 1000 '角球区半径
zqr = 9150 '中圈半径
! j% {/ l4 W( M/ n: w; s
* D& ^# [2 [0 s$ V5 e$ ROn Error Resume Next
chang = ThisDrawing.Utility.GetReal("长度(90000～120000)<105000>")
If Err.Number <> 0 Then '用户输入的不是有效数字
  chang = 105000
  Err.Clear '清除错误
End If
kuan = ThisDrawing.Utility.GetReal("宽度(45000～90000)<68000>")
If Err.Number <> 0 Then
" @- s9 w' x5 b% j* g9 C  kuan = 68000
End If
5 H& b4 h- Z1 l1 r4 N
' J5 d' b% M/ R, s7 c1 lcenterp = ThisDrawing.Utility.GetPoint(, "定位球场中心:")

0 P- C# f! u  N: S2 fSet courtlay = ThisDrawing.Layers.Add("足球场") '设置图层
: M% ]% t' S: E( i: [% g9 AThisDrawing.ActiveLayer = courtlay '把当前图层设为足球场图层
" Q7 s2 H6 {* H. F) u" |# _) _
" d" m4 R1 G* b2 y& G/ _- Z'画小禁区
! U) A6 j7 A4 t1 i) Q6 I. t- h# A1 Ulinep1(0) = centerp(0) + chang / 2
linep1(1) = centerp(1) + xjq / 2
0 B3 |/ K5 G" g1 C( X7 K. ?. D( ~- o9 A- klinep2(0) = centerp(0) + chang / 2 - xjq / 2
1 w7 H7 I# |) c% elinep2(1) = centerp(1) - xjq / 2
Call drawbox(linep1, linep2) '调用画矩形子程序


+ D% F" Q, i- e* |# j- ~7 S
# `8 d; ^  |6 ~'画大禁区
linep1(0) = centerp(0) + chang / 2
! j  z$ t; P; N: ~+ ?linep1(1) = centerp(1) + djq / 2
linep2(0) = centerp(0) + chang / 2 - djq / 2
linep2(1) = centerp(1) - djq / 2
! g, m2 E5 i1 Q3 dCall drawbox(linep1, linep2)
; T' e1 x" w0 K) Z

' 画罚球点
linep1(0) = centerp(0) + chang / 2 - fqd
" T' f, ^) d0 M+ w, n" b/ tlinep1(1) = centerp(1)
. u! l( c( x, f  s4 `" P" kCall ThisDrawing.ModelSpace.AddPoint(linep1)
'ThisDrawing.SetVariable "PDMODE", 32 '点样式
( `+ O1 |% h) tThisDrawing.SetVariable "PDSIZE", 30 '点的尺寸
$ y! t" A) Z8 j6 ]$ L. D! s5 k
3 Q1 l  h) @8 v8 k9 i( K" M9 `'画罚球弧，罚球弧圆心就是罚球点linep1
$ m' K2 U. a. N6 K5 y$ |$ z; f6 Ulinep3(0) = centerp(0) + chang / 2 - djq / 2
linep3(1) = centerp(1) + fqh / 2
6 x- P: }! [8 \1 [, Blinep4(0) = linep3(0) '两个端点的x轴相同
7 }; r7 B4 V* Dlinep4(1) = centerp(1) - fqh / 2
, |) y8 T! A$ P( L3 |- S: H4 P. Tang1 = ThisDrawing.Utility.AngleFromXAxis(linep1, linep3) '计算角度
ang2 = ThisDrawing.Utility.AngleFromXAxis(linep1, linep4)
4 c0 K( Y3 N! ]. W) z7 S) L2 s2 jCall ThisDrawing.ModelSpace.AddArc(linep1, zqr, ang1, ang2) '画弧

  n4 Y0 B6 x% E( ?
+ A6 @/ j/ q7 C$ U3 R" g* ^( b5 R'角球弧
ang1 = ThisDrawing.Utility.AngleToReal(90, 0) '角度转换为弧度
, H1 U7 M! l! Mang2 = ThisDrawing.Utility.AngleToReal(180, 0)
# P% v3 X4 Y" C+ Y. o/ R2 y4 x* dlinep1(0) = centerp(0) + chang / 2 '角球弧圆心
linep1(1) = centerp(1) - kuan / 2
6 {+ L* o9 d: j: \0 ?Call ThisDrawing.ModelSpace.AddArc(linep1, jqqr, ang1, ang2) '画弧

ang1 = ThisDrawing.Utility.AngleToReal(270, 0)
9 l. F! m, _9 mlinep1(1) = centerp(1) + kuan / 2
Call ThisDrawing.ModelSpace.AddArc(linep1, jqqr, ang2, ang1)
1 R7 X! g. S. i$ w# g) y, Q
6 p& O9 j7 g7 b; |9 c) {* u

" A& V: [2 A9 S'镜像轴
linep1(0) = centerp(0)
linep1(1) = centerp(1) - kuan / 2
  K3 p' u1 E% j: N- Llinep2(0) = centerp(0)
/ D0 E4 Q( l, vlinep2(1) = centerp(1) + kuan / 2

'镜像
( s# _  `2 F  l$ f  w' cFor Each ent In ThisDrawing.ModelSpace '所有模型空间的对象进行一次循环
  If ent.Layer = "足球场" Then '对象在"足球场"图层中
7 A5 K( P; |! E5 Z    ent.Mirror linep1, linep2 '镜像
  End If
Next ent

'画中线
Call ThisDrawing.ModelSpace.AddLine(linep1, linep2)
  U3 N( `. b5 O+ N( w
'画中圈
Call ThisDrawing.ModelSpace.AddCircle(centerp, zqr)

4 ]! x; d$ ~, ]2 @- X'画外框
linep1(0) = centerp(0) - chang / 2
linep1(1) = centerp(1) - kuan / 2
linep2(0) = centerp(0) + chang / 2
linep2(1) = centerp(1) + kuan / 2
- @+ v- @* {, ~( e, A) F: p5 KCall drawbox(linep1, linep2)
3 J* K8 w' f8 |+ u: E4 p; K# [
+ n( [: C: m$ u5 @# kZoomExtents '显示整个图形

1 ^. Y! j: z3 f( xEnd Sub

, L# _9 f4 }1 N" J9 y) L" w2 QPrivate Sub drawbox(p1, p2) '根据对角线坐标画矩形的子程序
Dim boxp(0 To 14) As Double
& D2 T3 P) O6 F6 y& a* D; U
boxp(0) = p1(0)
boxp(1) = p1(1)

, [& N4 d5 g( f: A9 K" P  vboxp(3) = p1(0)
' D3 g7 ~- `- g( _boxp(4) = p2(1)

boxp(6) = p2(0)
boxp(7) = p2(1)
; X8 ]4 H: a  B2 T/ O
: q) E5 c+ l- a; X& t0 {boxp(9) = p2(0)
0 o, `- J6 K; N1 |9 l( m/ \boxp(10) = p1(1)
! d: p7 u9 S, q# S7 G
boxp(12) = p1(0)
boxp(13) = p1(1)

: c% m+ g9 b0 y, W( D4 ZCall ThisDrawing.ModelSpace.AddPolyline(boxp)

End Sub
" N0 [2 J9 s! \0 k1 ~


# s5 m( U" B" p/ |$ D* V4 I4 U% Q" t
! \6 [, c3 i1 i- x6 e下面开始分析源码：

On Error Resume Next
chang = ThisDrawing.Utility.GetReal("长度(90～120)<10500>")
5 \# S7 v3 k: D1 k% rIf Err.Number <> 0 Then '用户输入的不是有效数字
chang = 10500
Err.Clear '清除错误
End If

1 z2 J) {) F- ]9 ?    这段代码的作用是要求用户输入一个足球场长度的数字，由于getreal只能输入数字，如果输入其他字符程序就会报错，所以先要用去掉错误提示：On Error Resume Next，虽然错误不再提示，但是出错代码会err.number改变，有兴趣的读者可以用变量跟踪的方法看看这个代码的数值。您只要记住，如果这个数字不是0，那么就是有错了，这时就可以把长度定为默认值，然后用Err.Clear语句把错误代码清零。
- }& W. M/ r+ p; L* w" E* k

8 `* P1 [. b, _3 I6 _% e( J. @5 X    在画小禁区的最后一行这样写：Call drawbox(linep1, linep2)
8 B7 B. _& u! x8 p7 F
* R( f# C+ g7 k5 ?0 [/ x& O    Drawbox并不是vba提供的方法，它是一个带参数的子程序。由于画足球场要画好几次矩形，
而vba没有提供一个现成的画矩形方法，如果每次都用一长串代码画矩形是很麻烦的，所以需要把这些麻烦的代码写到一个子程序中，在需要时只有写一条调用语句就行了。这个子程序最后几行，从“Private Sub drawbox(p1, p2) ”开始，到end sub结束，p1,p2是参数，调用时也必须写两个参数：linep1、linep2。

+ K4 F) [2 m0 ^; E1 J( O' h% S+ h' M
ang1 = ThisDrawing.Utility.AngleFromXAxis(linep1, linep3) '计算角度
$ [/ L; m6 b; n  m5 Wang2 = ThisDrawing.Utility.AngleFromXAxis(linep1, linep4)
Call ThisDrawing.ModelSpace.AddArc(linep1, zqr, ang1, ang2) '画弧
9 _) O3 d5 m) [3 d# Q
    画圆用addarc方法，需要4个参数：圆心、半径、起始角度、结束角度。AngleFromXAxis用于计算角度，其参数需要两个点坐标
/ A. ~" K! l. E  S) Q. n
下面看镜像操作：
For Each ent In ThisDrawing.ModelSpace '所有模型空间的对象进行一次循环
  If ent.Layer = "足球场" Then '对象在"足球场"图层中
    ent.Mirror linep1, linep2 '镜像
  End If
7 j9 A& ~7 E4 m7 VNext ent

# N5 G' q8 q( C7 x# D* {: A    本例只对“足球场”图层中的对象进行镜像，所以要对全部对象进行循环，判断对象的图层属性，只有位于“足球场”图层中的对象才作镜像。


, W6 n# J! J7 h% u- _+ y本课思考题：

1、对本课的例程进行修改，当用户输入长、宽不在规定的范围时要求用户重新输入
) g1 ]) W$ w7 L* r/ P! Y
2、设计一张简单的平面图，用户输入2个参数，其他尺寸写进程序中

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

tianyunxuan

定义块方法：

5 X) A: }2 ?( G" DSet blocksobj=ThisDrawing.Blocks.Add(基点, 块名)
  U2 Y4 V4 o' M+ C3 k  k把选择集加入块中的方法：
9 m1 m* M9 h( @' uThisDrawing.CopyObjects(选择集,块)
3 ^% q8 b& P2 W' C% L( R- r% R插入块方法：
ThisDrawing.ModelSpace.InsertBlock(插入点,块名, X轴比例,Y轴比例,Z轴比例, 旋转角度)
5 R  V( ~9 w7 D/ S0 _) _& F画块属性方法：
% f! S3 Q' _7 [% }ThisDrawing.ModelSpace.AddAttribute(文字高度,模式,提示字符, 插入点, 显示字符,默认值)
' j8 n2 W2 l6 r) M一共有五种模式，在输入时会有提示，其中最常用的是“acAttributeModeNormal”普通模式
: b' y& l- U& y# |! E
6 J  R2 Z# N( t$ \  g
4 A' C$ O8 X4 h$ H) X" V0 Z; x下面的例题是利用属性块画足球场的阵型图。
程序画出一个球员块，然后把块写到用户指定位置，球员号码由程序自动递增，把球员姓名改为用户输入值。画足球场请参阅上一课内容。
5 d3 t( t2 h/ I6 h5 s- U




0 Q' Z* z. ?; V7 Y( M1 u2 f% M1 P
编程思路：
1．定义一个空块
1 {: a) B7 ~. P) v3 t2．在块中画一段弧（球服衣领）
3．画多段线，镜像画出球衣
4．画块属性，由于块属性默认的对齐方式是左对齐，而球员号码应该居中，所以必须把块的对齐属性改为居中。但是当这个属性更改时块属性对齐点会自动归零，所以不得不再次更改对齐点属性
5．把多段线和属性复制到块中
1 ^' i6 ^" p: `5 g* O  s. B6．提示用户点选球员位置和姓名
7．插入块，修改球衣号码属性、球员姓名属性

以下是源码，附有详细的注释，如果有疑问，建议用变量跟踪法研究一下。
Sub team()
Dim playerlay As AcadLayer '定义球员图层
Dim playerblock As AcadBlock '定义块变量
Dim arcc(0 To 2) As Double '圆弧圆心
4 y+ I* r6 p1 y: f/ O* y3 V* I- BDim linep1(0 To 2) As Double '线条端点1
Dim linep2(0 To 2) As Double '线条端点2
9 L2 v1 _: [1 nDim pline(0 To 20) As Double '定义队服右侧多段线7个顶点
: g5 G. e# d' M2 ?Dim basep(0 To 2) As Double '块基点
Dim playernumberpoint(0 To 2) As Double '块属性插入点
Dim mytxt As AcadTextStyle '定义mytxt变量为文本样式
  z# s, m! _' @0 fDim blockRef As AcadBlockReference '定义块属性变量
/ v3 ]" R# L( w' q+ bDim Attr3 As Variant '插入块属性变量
1 q- o0 K5 r3 y4 W- N$ ?8 Q
& [  ~6 n# e$ R, Q9 K+ n. eSet playerblock = ThisDrawing.Blocks.Add(basep, "球员") '定义一个"球员"的块
7 O1 K4 [- h: y% @
arcc(0) = 0
arcc(1) = 430
Call playerblock.AddArc(arcc, 50, ThisDrawing.Utility.AngleToReal(180, 0), 0) '画弧并加入块中

pline(0) = 0
3 f8 N5 X4 O/ s* ~9 j* opline(1) = 20
  G8 R* i1 {: L- }
- U) z" g* W- X* Q8 Mpline(3) = 100
$ U6 y8 j1 q7 a3 a& t! _pline(4) = 20

/ I8 s$ Y: x7 h( d/ c) o" upline(6) = 100
& i7 Y9 P1 K7 Y  [$ Qpline(7) = 250

0 l, g  p3 ?; ^0 v3 q8 p: lpline(9) = 125
* U9 v5 x5 m! t# Ypline(10) = 207
& @8 D/ {6 Q9 m+ [9 h
4 S# r/ @1 t$ K: H0 t6 F3 ^pline(12) = 212
pline(13) = 257


3 A, W. K: R8 }. U; q5 z1 Lpline(15) = 112
+ d% J% S7 k8 @+ q1 n  Cpline(16) = 430

7 R; U# V1 B, n) w: w, P; V# e3 Q# P
( P5 L9 A  E; |pline(18) = 50
pline(19) = 430
+ r; z. ~  q* l/ E0 I
Set line1 = ThisDrawing.ModelSpace.AddPolyline(pline) '画队服右侧多段线
+ m% r3 }9 G9 ]3 s3 y; ?: I& f; I
linep2(1) = 1 '镜像轴第二点位于Y轴上任一点
Set line2 = line1.Mirror(linep1, linep2) '镜像获得另一半多段线

Dim p(0 To 2) As Double '定义坐标变量
5 {1 m! D$ `& ?' p8 xSet mytxt = ThisDrawing.TextStyles.Add("mytxt") '添加mytxt样式
mytxt.fontFile = "c:\windows\fonts\simfang.ttf" '设置字体文件为仿宋体
ThisDrawing.ActiveTextStyle = mytxt '将当前文字样式设置为mytxt
4 B6 Q( R6 y: Z4 W# I
0 U. `' d1 u) p6 j/ W# T8 J' v4 ]playernumberpoint(0) = 0 '块属性位置
playernumberpoint(1) = 200
Set attr1 = ThisDrawing.ModelSpace.AddAttribute(100, acAttributeModeNormal, "号码", playernumberpoint, "X", 0) '画块属性
attr1.Alignment = 7 '居中
3 b  ?4 j, j* h  e5 Nattr1.TextAlignmentPoint = playernumberpoint '重定义对齐点
Set attr2 = ThisDrawing.ModelSpace.AddAttribute(100, acAttributeModeNormal, "姓名", playernumberpoint, "???", 0) '画块属性
attr2.Alignment = 7 '居中
4 Q- H5 Q5 x6 D9 `
. K. ?  ?1 v$ [& J
Dim objCollection(0 To 3) As Object '创建选择集
8 }# {7 N2 f8 l4 {8 ]' \6 |  aSet objCollection(0) = line1 '线条1加入选择集
7 \& f$ q& O. y; E+ vSet objCollection(1) = line2 '线条2加入选择集
Set objCollection(2) = attr1 '属性1加入选择集
Set objCollection(3) = attr2 '属性2加入选择集

3 ]* `1 N+ W6 @9 f; {Call ThisDrawing.CopyObjects(objCollection, playerblock) '把选择集加入块中
! j( M4 H4 l4 x4 g5 ^' S
6 s3 e3 f0 M7 y  ?+ @5 H( F/ hFor Each element In objCollection '在选择集中进行循环
  element.Delete '删除线条和属性(此操作并不影响已创建的块)
Next


Set playerlay = ThisDrawing.Layers.Add("球员") '新建图层
. v3 H; w) Z$ r! G  x7 Q' |. }, `playerlay.color = 2 '为黄色
ThisDrawing.ActiveLayer = playerlay '将当前图层设置为球员图层

Dim p1 As Variant '块插入点位置
: B, j9 h, X* m9 R: I
2 X! l" a+ r- a- c7 SFor i = 1 To 11 '插入块
) E# J7 T! o2 E, i- o  pstring = CStr(i) & "号球员位置："
  p1 = ThisDrawing.Utility.GetPoint(, pstring) '点选球员位置坐标
  nstring = ThisDrawing.Utility.GetString(30, "球员姓名：")
6 v- ]3 l( U9 V: u! v  Set blockRef = ThisDrawing.ModelSpace.InsertBlock(p1, "球员", 1, 1, 1, 0) '插入块
  Attr3 = blockRef.GetAttributes '获取块属性
; G& D/ J* j( p9 V  Attr3(0).TextString = CStr(i) '赋值球员号码
  Attr3(1).TextString = nstring '赋值球员姓名
Next
4 a  W: o" g  Z" h" c  Q
9 q2 H/ u/ e: h: r: XEnd Sub

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

trinco

很有帮助！谢谢lz

cgc

终于看好了，写得很不错， 连我从来不写程序的人都能看得懂了
3 \" x$ [) [( `; P7 V; ]9 g6 p
5 s4 n! y8 Z+ r6 s好好学习，感觉函数 方面还有很多的东西不是很懂

8 E+ a* K) Q0 Y有函数库可以查阅么？
  V! L3 H& m! U- O, N% H
6 ^0 j8 Q& d- I6 o, E1 F买书也行

nebs

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

lianghn1986

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

pianpi111

auto cad vba第一次听说
学学

nebs

顶！！ 学习中.....

sod11791

太难了，能学会吗？

kyokula

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