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

pengyg1204

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

wangpiwujing

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

yhfsmu

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

设计从零

支持楼主！！！
！

hellmen

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

tianyunxuan

简单地讲，参数化设计就是根据参数进行精确绘图，绘图所需要的参数也可以由用户手工输入。真正的参数化设计往往需要数据库操作，为了简化程序，把数据库部分放在以后的课程中详细讲解。
  d9 {8 J0 A$ \. B' S- [. i
* S9 T) y& C  r( _" q2 u7 @    本课的例程是画一个标准足球场。足球场长度90～120米，宽度45～90米，而红色标注的尺寸是程序默认的，绿色标注固定不变。




Sub court()
Dim courtlay As AcadLayer '定义球场图层
Dim ent As AcadEntity '镜像对象
Dim linep1(0 To 2) As Double '线条端点1
Dim linep2(0 To 2) As Double '线条端点2
Dim linep3(0 To 2) As Double '罚球弧端点1
7 C6 F. u7 o' C( ^2 f2 ^Dim linep4(0 To 2) As Double '罚球弧端点2
" J, L- E3 s: s9 n* U3 IDim centerp As Variant '中心坐标
xjq = 11000 '小禁区尺寸
/ H8 A4 |9 X5 T0 y0 tdjq = 33000 '大禁区尺寸
fqd = 11000 '罚球点位置
6 a& V) v6 S0 Z$ C- ifqr = 9150 '罚球弧半径
fqh = 14634.98 '罚球弧弦长
# U* S1 d6 y: N  p7 N/ ljqqr = 1000 '角球区半径
2 Q; V4 \+ T) }! ~zqr = 9150 '中圈半径
2 G- M% X8 o4 G4 X! b8 Y
8 H! d" w9 X8 U0 Z/ C! FOn Error Resume Next
chang = ThisDrawing.Utility.GetReal("长度(90000～120000)<105000>")
If Err.Number <> 0 Then '用户输入的不是有效数字
- w8 d% u/ g% ?1 d2 v. Y* Q  chang = 105000
. \  B3 l/ x0 q$ p1 z0 Q$ v  Err.Clear '清除错误
7 r$ ?; s! b1 `+ B( JEnd If
kuan = ThisDrawing.Utility.GetReal("宽度(45000～90000)<68000>")
If Err.Number <> 0 Then
  kuan = 68000
End If

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

. E9 L# u9 s' ~Set courtlay = ThisDrawing.Layers.Add("足球场") '设置图层
ThisDrawing.ActiveLayer = courtlay '把当前图层设为足球场图层

'画小禁区
$ V" _! R7 b! n+ [# y) C. vlinep1(0) = centerp(0) + chang / 2
- Q/ @8 L6 K; x( H0 c7 Q0 V8 f) k7 ilinep1(1) = centerp(1) + xjq / 2
linep2(0) = centerp(0) + chang / 2 - xjq / 2
linep2(1) = centerp(1) - xjq / 2
3 g% i" @9 b, J0 i- O' E2 G: tCall drawbox(linep1, linep2) '调用画矩形子程序



'画大禁区
linep1(0) = centerp(0) + chang / 2
% a; l& Q% O& u/ p" N' m3 mlinep1(1) = centerp(1) + djq / 2
linep2(0) = centerp(0) + chang / 2 - djq / 2
linep2(1) = centerp(1) - djq / 2
7 a- w; W7 q) S0 tCall drawbox(linep1, linep2)
: J% b' Y2 @; A" f

' 画罚球点
linep1(0) = centerp(0) + chang / 2 - fqd
linep1(1) = centerp(1)
Call ThisDrawing.ModelSpace.AddPoint(linep1)
'ThisDrawing.SetVariable "PDMODE", 32 '点样式
: m) l; ]# u0 M2 AThisDrawing.SetVariable "PDSIZE", 30 '点的尺寸

5 @. M, c& z: P1 _'画罚球弧，罚球弧圆心就是罚球点linep1
( C, \3 E+ m* ]5 s3 P* H( x4 ylinep3(0) = centerp(0) + chang / 2 - djq / 2
linep3(1) = centerp(1) + fqh / 2
linep4(0) = linep3(0) '两个端点的x轴相同
5 m$ R& U; P( k0 l% N& vlinep4(1) = centerp(1) - fqh / 2
3 ]3 S: P8 I) U, vang1 = ThisDrawing.Utility.AngleFromXAxis(linep1, linep3) '计算角度
ang2 = ThisDrawing.Utility.AngleFromXAxis(linep1, linep4)
Call ThisDrawing.ModelSpace.AddArc(linep1, zqr, ang1, ang2) '画弧
6 ^. i+ K" K, L& O" e

'角球弧
ang1 = ThisDrawing.Utility.AngleToReal(90, 0) '角度转换为弧度
: O  N( ]; ^; }9 H9 [. Hang2 = ThisDrawing.Utility.AngleToReal(180, 0)
linep1(0) = centerp(0) + chang / 2 '角球弧圆心
linep1(1) = centerp(1) - kuan / 2
; R. O) Z" ~4 T# f6 }7 X9 y; h- eCall ThisDrawing.ModelSpace.AddArc(linep1, jqqr, ang1, ang2) '画弧

ang1 = ThisDrawing.Utility.AngleToReal(270, 0)
linep1(1) = centerp(1) + kuan / 2
Call ThisDrawing.ModelSpace.AddArc(linep1, jqqr, ang2, ang1)

% Z/ n( f1 {# ]' ]
" T! U5 t- X$ o  N$ A5 K4 T( f! f% N
& ]% ]7 N- y' V3 m1 m) X'镜像轴
linep1(0) = centerp(0)
6 d6 ]3 X9 B+ olinep1(1) = centerp(1) - kuan / 2
linep2(0) = centerp(0)
linep2(1) = centerp(1) + kuan / 2

'镜像
- r0 p- U" E9 TFor Each ent In ThisDrawing.ModelSpace '所有模型空间的对象进行一次循环
  If ent.Layer = "足球场" Then '对象在"足球场"图层中
" M: E# L9 f, Y# A: B: r4 W, o    ent.Mirror linep1, linep2 '镜像
, T) e8 S- V, V0 _/ c  End If
Next ent

% F- a" }+ m! o( O( |$ }! F+ N9 f'画中线
Call ThisDrawing.ModelSpace.AddLine(linep1, linep2)
0 G" s- _# O6 P/ _" Y# t7 {) b+ |
'画中圈
" Y, Z' H( i9 w! T% Y) D1 m8 @Call ThisDrawing.ModelSpace.AddCircle(centerp, zqr)
2 P: K2 D& i% V6 M8 r
  w5 G6 s+ ?. U( D" x'画外框
linep1(0) = centerp(0) - chang / 2
" J% H+ X; ]  d+ @# olinep1(1) = centerp(1) - kuan / 2
6 x- q; ]* y* i& Z7 E  H! qlinep2(0) = centerp(0) + chang / 2
linep2(1) = centerp(1) + kuan / 2
$ {/ J" l# c7 _# iCall drawbox(linep1, linep2)

ZoomExtents '显示整个图形

3 u  j$ y, n& B  _' N9 f  lEnd Sub
& M$ g$ [, k7 `& n+ Q
Private Sub drawbox(p1, p2) '根据对角线坐标画矩形的子程序
: v' m1 W( r7 G8 jDim boxp(0 To 14) As Double
/ ?& A% v/ C; [# V* U
boxp(0) = p1(0)
boxp(1) = p1(1)

boxp(3) = p1(0)
* j6 E$ U$ d' A; t4 s6 Iboxp(4) = p2(1)

* b& G; M* _" {1 Zboxp(6) = p2(0)
boxp(7) = p2(1)

+ n( R# ?$ R; j1 [7 m5 lboxp(9) = p2(0)
0 F8 t* _: q& [" ~boxp(10) = p1(1)

boxp(12) = p1(0)
, n( q9 E4 U1 o# I6 ^0 O4 ?1 K/ W; }7 @boxp(13) = p1(1)
9 S2 @; X+ S; Z" O1 Q2 o  p
Call ThisDrawing.ModelSpace.AddPolyline(boxp)
+ B  T7 i3 X' i% [: d: O! \
6 P% z$ {- y6 SEnd Sub

4 v  S' K1 I3 y; i/ k: M

' }. _# r$ c8 c0 j+ `3 _
+ t) w) t7 {2 |+ S% A! l7 w下面开始分析源码：

On Error Resume Next
8 Z& d( E5 N" k1 A$ k: P" Z3 c0 f0 ~chang = ThisDrawing.Utility.GetReal("长度(90～120)<10500>")
2 f1 ^+ H8 e" P: BIf Err.Number <> 0 Then '用户输入的不是有效数字
3 `7 G6 i- T; n. z' h# A  O. o) d$ Lchang = 10500
2 G9 B& X! d# `+ b* W5 H' IErr.Clear '清除错误
End If

    这段代码的作用是要求用户输入一个足球场长度的数字，由于getreal只能输入数字，如果输入其他字符程序就会报错，所以先要用去掉错误提示：On Error Resume Next，虽然错误不再提示，但是出错代码会err.number改变，有兴趣的读者可以用变量跟踪的方法看看这个代码的数值。您只要记住，如果这个数字不是0，那么就是有错了，这时就可以把长度定为默认值，然后用Err.Clear语句把错误代码清零。

& [$ Q* z- ~0 f2 K- `
    在画小禁区的最后一行这样写：Call drawbox(linep1, linep2)
4 m& {' O! M0 l" B% ^+ F
    Drawbox并不是vba提供的方法，它是一个带参数的子程序。由于画足球场要画好几次矩形，
- G( x* H- j5 j! V8 |1 v; i+ S而vba没有提供一个现成的画矩形方法，如果每次都用一长串代码画矩形是很麻烦的，所以需要把这些麻烦的代码写到一个子程序中，在需要时只有写一条调用语句就行了。这个子程序最后几行，从“Private Sub drawbox(p1, p2) ”开始，到end sub结束，p1,p2是参数，调用时也必须写两个参数：linep1、linep2。


ang1 = ThisDrawing.Utility.AngleFromXAxis(linep1, linep3) '计算角度
ang2 = ThisDrawing.Utility.AngleFromXAxis(linep1, linep4)
2 T& ?1 j6 E9 p& i8 mCall ThisDrawing.ModelSpace.AddArc(linep1, zqr, ang1, ang2) '画弧
; _6 S3 X5 |" t4 Y& f  ?# q6 R" b0 U
    画圆用addarc方法，需要4个参数：圆心、半径、起始角度、结束角度。AngleFromXAxis用于计算角度，其参数需要两个点坐标
2 }5 k7 G0 c# ]& e, H; G; q9 ]" R
下面看镜像操作：
3 a% a0 @( ^- P9 ^6 `2 }$ }9 @! dFor Each ent In ThisDrawing.ModelSpace '所有模型空间的对象进行一次循环
  If ent.Layer = "足球场" Then '对象在"足球场"图层中
    ent.Mirror linep1, linep2 '镜像
. o  _8 H7 T5 Z7 e9 I  End If
Next ent

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


本课思考题：

3 H( B* d7 N0 L' V# z' z1、对本课的例程进行修改，当用户输入长、宽不在规定的范围时要求用户重新输入
, c% i4 E% A% X2 E0 q, n
  B1 x9 Q5 p7 ]- f2、设计一张简单的平面图，用户输入2个参数，其他尺寸写进程序中

& @) q. L- ]8 f0 r% i[ 本帖最后由 tianyunxuan 于 2007-5-26 20:10 编辑 ]

tianyunxuan

定义块方法：
6 h+ Q* L: r, u' H4 l, r2 U
9 q! n, P9 p$ l/ a; Y, l* D! gSet blocksobj=ThisDrawing.Blocks.Add(基点, 块名)
& e( C9 E& f' y* t把选择集加入块中的方法：
ThisDrawing.CopyObjects(选择集,块)
插入块方法：
( n" e& u- ]' H: @- L: WThisDrawing.ModelSpace.InsertBlock(插入点,块名, X轴比例,Y轴比例,Z轴比例, 旋转角度)
9 p, a# ]0 n, t; y! [" o  b画块属性方法：
3 S$ o7 ]  D, ]9 p3 Y+ eThisDrawing.ModelSpace.AddAttribute(文字高度,模式,提示字符, 插入点, 显示字符,默认值)
一共有五种模式，在输入时会有提示，其中最常用的是“acAttributeModeNormal”普通模式

# D/ L  A2 [3 Q+ r: M
下面的例题是利用属性块画足球场的阵型图。
程序画出一个球员块，然后把块写到用户指定位置，球员号码由程序自动递增，把球员姓名改为用户输入值。画足球场请参阅上一课内容。




9 v; ~/ r) _  l( L7 j

# o( c* U& @# |- M: W. c, V. p3 n编程思路：
8 S! v( g7 O- i% g' O  ]6 j1．定义一个空块
$ V+ B  ?0 ]( I0 b) _# [9 {' \2．在块中画一段弧（球服衣领）
0 k) A1 O$ Z% o( c3．画多段线，镜像画出球衣
' d7 b  P0 a! Y/ M4．画块属性，由于块属性默认的对齐方式是左对齐，而球员号码应该居中，所以必须把块的对齐属性改为居中。但是当这个属性更改时块属性对齐点会自动归零，所以不得不再次更改对齐点属性
5．把多段线和属性复制到块中
6．提示用户点选球员位置和姓名
7．插入块，修改球衣号码属性、球员姓名属性

以下是源码，附有详细的注释，如果有疑问，建议用变量跟踪法研究一下。
Sub team()
6 B+ m. P. d, p) @* X* tDim playerlay As AcadLayer '定义球员图层
Dim playerblock As AcadBlock '定义块变量
Dim arcc(0 To 2) As Double '圆弧圆心
Dim linep1(0 To 2) As Double '线条端点1
3 i/ C7 T& K6 fDim linep2(0 To 2) As Double '线条端点2
Dim pline(0 To 20) As Double '定义队服右侧多段线7个顶点
Dim basep(0 To 2) As Double '块基点
Dim playernumberpoint(0 To 2) As Double '块属性插入点
( P$ W! H% C( m" e# f  oDim mytxt As AcadTextStyle '定义mytxt变量为文本样式
Dim blockRef As AcadBlockReference '定义块属性变量
Dim Attr3 As Variant '插入块属性变量
% T3 P9 j" ~) T% r- C9 ~3 \
# p( H/ F8 o3 G; m3 A$ k' d  TSet playerblock = ThisDrawing.Blocks.Add(basep, "球员") '定义一个"球员"的块
& }5 K! d& C* E
arcc(0) = 0
arcc(1) = 430
5 `+ m* ?1 x. d7 D1 H4 u, ^% _Call playerblock.AddArc(arcc, 50, ThisDrawing.Utility.AngleToReal(180, 0), 0) '画弧并加入块中

pline(0) = 0
% b: G0 q9 M: A/ t# ^1 y7 ]. P% kpline(1) = 20
$ E4 Z6 ^+ \. e8 B2 ~
6 A8 w1 R' z2 Epline(3) = 100
) M" I( o9 h: D* C1 p3 J$ ?pline(4) = 20

pline(6) = 100
5 w2 U8 R( a! C# x+ T! R/ mpline(7) = 250
6 `! j8 r$ e! j; J" _2 C
pline(9) = 125
pline(10) = 207
$ [* A7 f. M3 Z# h" w
pline(12) = 212
pline(13) = 257
( s; v) {! j% r" x8 u

pline(15) = 112
. E7 p* v( L+ A4 Q, \pline(16) = 430

6 S* ^7 ?/ v1 c+ I  r+ I7 t
3 _0 X4 r; ]$ Upline(18) = 50
pline(19) = 430
; `; `: i" w+ {1 F
Set line1 = ThisDrawing.ModelSpace.AddPolyline(pline) '画队服右侧多段线
/ f& j( }' @* L# b* @0 n9 N
linep2(1) = 1 '镜像轴第二点位于Y轴上任一点
Set line2 = line1.Mirror(linep1, linep2) '镜像获得另一半多段线
6 D1 _9 \: B- _& i4 \8 `+ s3 W
1 f+ W* C* r8 I: r0 VDim p(0 To 2) As Double '定义坐标变量
Set mytxt = ThisDrawing.TextStyles.Add("mytxt") '添加mytxt样式
mytxt.fontFile = "c:\windows\fonts\simfang.ttf" '设置字体文件为仿宋体
ThisDrawing.ActiveTextStyle = mytxt '将当前文字样式设置为mytxt
" y3 }5 s! Y2 J: g  H
3 H3 L; [5 q7 J, s* X1 Hplayernumberpoint(0) = 0 '块属性位置
playernumberpoint(1) = 200
  _; C! l1 V( ?$ @; ~( r/ d7 U" LSet attr1 = ThisDrawing.ModelSpace.AddAttribute(100, acAttributeModeNormal, "号码", playernumberpoint, "X", 0) '画块属性
attr1.Alignment = 7 '居中
attr1.TextAlignmentPoint = playernumberpoint '重定义对齐点
Set attr2 = ThisDrawing.ModelSpace.AddAttribute(100, acAttributeModeNormal, "姓名", playernumberpoint, "???", 0) '画块属性
attr2.Alignment = 7 '居中


! K% \) W5 ^2 o. W& c* T! ?Dim objCollection(0 To 3) As Object '创建选择集
, c( S3 [% I4 A/ A5 VSet objCollection(0) = line1 '线条1加入选择集
* |3 }" `1 _! [% C0 T, B$ mSet objCollection(1) = line2 '线条2加入选择集
Set objCollection(2) = attr1 '属性1加入选择集
* E- h% `; Q2 e, ~, e' @, zSet objCollection(3) = attr2 '属性2加入选择集
- e9 E/ q- p1 R* }+ b! g8 h9 g
Call ThisDrawing.CopyObjects(objCollection, playerblock) '把选择集加入块中
& j  Z2 m; |2 h& f, D# z
, I5 l: H; J5 D1 ZFor Each element In objCollection '在选择集中进行循环
/ W8 ]/ H2 T* F; v! D& I  element.Delete '删除线条和属性(此操作并不影响已创建的块)
Next
8 w+ P1 U, }) h
9 j# W  \' M% p* I1 K& S3 k
Set playerlay = ThisDrawing.Layers.Add("球员") '新建图层
2 A& ^0 s0 a, N! g! o  k3 k  Pplayerlay.color = 2 '为黄色
ThisDrawing.ActiveLayer = playerlay '将当前图层设置为球员图层
2 m  _: d5 D0 ?5 Y  c* j
Dim p1 As Variant '块插入点位置

For i = 1 To 11 '插入块
5 H, H1 z+ z. n7 H# X! ?; G( R6 W  pstring = CStr(i) & "号球员位置："
! E1 h5 q; O: Q9 O" h- d/ Z+ r  p1 = ThisDrawing.Utility.GetPoint(, pstring) '点选球员位置坐标
1 P& H" q7 z9 G: v8 e6 ~+ x$ P  nstring = ThisDrawing.Utility.GetString(30, "球员姓名：")
% ^% ~" N$ k& R  Set blockRef = ThisDrawing.ModelSpace.InsertBlock(p1, "球员", 1, 1, 1, 0) '插入块
  Attr3 = blockRef.GetAttributes '获取块属性
  Attr3(0).TextString = CStr(i) '赋值球员号码
& v  y' N  L5 ?+ I1 p  Attr3(1).TextString = nstring '赋值球员姓名
5 K3 i! C4 F6 B" `: sNext

( ~" P7 m5 n" y4 o) _  `# D0 QEnd Sub
6 B- ]) }2 S4 F9 k
4 R) S# s  n" R  n$ |9 T" s本课思考题：
' b% y  N/ U& _4 @; h8 v' i# \1、在本课例程的最后一段增加出错陷阱代码，当用户输入非正常数值时退出程序
8 U/ A' v, I: a2 R* O+ Y5 t. e2、画一个简易路灯块，用属性块做为路灯编号，由用户点选路灯位置，程序画路灯时自动为路灯编号

trinco

很有帮助！谢谢lz

cgc

终于看好了，写得很不错， 连我从来不写程序的人都能看得懂了
1 i  d1 P0 G8 ]3 u
好好学习，感觉函数 方面还有很多的东西不是很懂
  I, m" m7 s5 C
9 p+ w! W. Y- @# S2 b% G+ E" E有函数库可以查阅么？

买书也行

nebs

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

lianghn1986

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

pianpi111

auto cad vba第一次听说
学学

nebs

顶！！ 学习中.....

sod11791

太难了，能学会吗？

kyokula

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