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

pengyg1204

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

wangpiwujing

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

yhfsmu

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

设计从零

支持楼主！！！
！

hellmen

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

tianyunxuan

简单地讲，参数化设计就是根据参数进行精确绘图，绘图所需要的参数也可以由用户手工输入。真正的参数化设计往往需要数据库操作，为了简化程序，把数据库部分放在以后的课程中详细讲解。
# i3 ?- I1 `. v1 v
    本课的例程是画一个标准足球场。足球场长度90～120米，宽度45～90米，而红色标注的尺寸是程序默认的，绿色标注固定不变。
, M# Y: \2 ?3 W6 `7 H: m: M* r
. }8 l6 Y; O2 m; V0 R; q* K: I


Sub court()
, e! \* V' ?$ U6 WDim courtlay As AcadLayer '定义球场图层
Dim ent As AcadEntity '镜像对象
Dim linep1(0 To 2) As Double '线条端点1
Dim linep2(0 To 2) As Double '线条端点2
3 G  u. |. R8 z* GDim linep3(0 To 2) As Double '罚球弧端点1
Dim linep4(0 To 2) As Double '罚球弧端点2
5 q. _- k! h% t% R5 EDim centerp As Variant '中心坐标
xjq = 11000 '小禁区尺寸
djq = 33000 '大禁区尺寸
  z. k3 A- x: n$ Z! `fqd = 11000 '罚球点位置
# F7 |" G( F' z& L% t* G' B" S; k# yfqr = 9150 '罚球弧半径
fqh = 14634.98 '罚球弧弦长
jqqr = 1000 '角球区半径
! |7 G: t+ a# o# {) Jzqr = 9150 '中圈半径

! }! s3 V0 y8 p7 T0 z/ }2 aOn Error Resume Next
chang = ThisDrawing.Utility.GetReal("长度(90000～120000)<105000>")
If Err.Number <> 0 Then '用户输入的不是有效数字
9 I# O7 a% ?. V& L" H2 _  chang = 105000
, K. E& @/ l0 Y) c) p4 F* N/ u$ L+ k  Err.Clear '清除错误
End If
kuan = ThisDrawing.Utility.GetReal("宽度(45000～90000)<68000>")
If Err.Number <> 0 Then
  kuan = 68000
# v/ p; D; i3 t. q8 [: V( `End If
5 R' Y7 ~- V8 W, I- p
" ]% W" V5 @& @' dcenterp = ThisDrawing.Utility.GetPoint(, "定位球场中心:")

- ^' Y. B0 K4 I, ^5 m) j1 O' vSet courtlay = ThisDrawing.Layers.Add("足球场") '设置图层
' c# A. `5 `2 [; [4 \' L3 `ThisDrawing.ActiveLayer = courtlay '把当前图层设为足球场图层
4 l5 l. R4 m0 a
'画小禁区
* W2 B; G  w9 }- u: alinep1(0) = centerp(0) + chang / 2
6 N/ o( G3 F/ hlinep1(1) = centerp(1) + xjq / 2
linep2(0) = centerp(0) + chang / 2 - xjq / 2
linep2(1) = centerp(1) - xjq / 2
Call drawbox(linep1, linep2) '调用画矩形子程序

: z0 D1 Q7 I: [) R4 L* I; q6 }
9 G3 h2 S* {) X- Z" u0 s, o$ {
6 Z# B6 U6 ]* e6 k'画大禁区
linep1(0) = centerp(0) + chang / 2
linep1(1) = centerp(1) + djq / 2
linep2(0) = centerp(0) + chang / 2 - djq / 2
0 L/ ], ^2 v7 X) X( Flinep2(1) = centerp(1) - djq / 2
. l: w$ b& [" P6 MCall drawbox(linep1, linep2)
" ~* w) ^6 v4 T

' 画罚球点
0 c$ `/ z# J* \3 vlinep1(0) = centerp(0) + chang / 2 - fqd
- f2 Z  p8 V/ flinep1(1) = centerp(1)
+ F3 }) I1 o, nCall ThisDrawing.ModelSpace.AddPoint(linep1)
'ThisDrawing.SetVariable "PDMODE", 32 '点样式
ThisDrawing.SetVariable "PDSIZE", 30 '点的尺寸
' F! D% Y) ~* ~* T7 z
+ Q2 G4 \6 D( w; ?6 c'画罚球弧，罚球弧圆心就是罚球点linep1
$ i3 b& w$ w% V. flinep3(0) = centerp(0) + chang / 2 - djq / 2
linep3(1) = centerp(1) + fqh / 2
: C% ^% x5 z) U$ h' r& ?linep4(0) = linep3(0) '两个端点的x轴相同
linep4(1) = centerp(1) - fqh / 2
ang1 = ThisDrawing.Utility.AngleFromXAxis(linep1, linep3) '计算角度
ang2 = ThisDrawing.Utility.AngleFromXAxis(linep1, linep4)
Call ThisDrawing.ModelSpace.AddArc(linep1, zqr, ang1, ang2) '画弧
- n7 o' _# z6 n4 f* g" E

'角球弧
. w- s: {  t& {! Tang1 = ThisDrawing.Utility.AngleToReal(90, 0) '角度转换为弧度
/ `* k( X  t* Pang2 = ThisDrawing.Utility.AngleToReal(180, 0)
linep1(0) = centerp(0) + chang / 2 '角球弧圆心
linep1(1) = centerp(1) - kuan / 2
9 K' D$ ~$ {5 n% S5 J. wCall ThisDrawing.ModelSpace.AddArc(linep1, jqqr, ang1, ang2) '画弧

ang1 = ThisDrawing.Utility.AngleToReal(270, 0)
8 O8 |5 g! p3 k6 U; `linep1(1) = centerp(1) + kuan / 2
Call ThisDrawing.ModelSpace.AddArc(linep1, jqqr, ang2, ang1)
/ e0 V) M$ ^7 k  }3 R


( @# x( X1 t+ F9 H, x# T'镜像轴
linep1(0) = centerp(0)
linep1(1) = centerp(1) - kuan / 2
8 Q$ p7 I5 }; G6 a& Z4 _/ hlinep2(0) = centerp(0)
linep2(1) = centerp(1) + kuan / 2

( W  H7 R' F) J. y5 [" P'镜像
7 X3 `1 P; l. O/ a# a, gFor Each ent In ThisDrawing.ModelSpace '所有模型空间的对象进行一次循环
8 t6 y2 u: l  g# A: R7 B7 z  If ent.Layer = "足球场" Then '对象在"足球场"图层中
    ent.Mirror linep1, linep2 '镜像
4 n' y3 T1 b/ Z$ h. u% m4 F$ ]  End If
- m- O. q; n( ]8 j* KNext ent
2 h* x, C% w% u* Z9 L9 m
1 s, Q5 L0 s8 ^0 ]8 n'画中线
) R5 l% r9 x$ i4 J4 ZCall ThisDrawing.ModelSpace.AddLine(linep1, linep2)

, {7 A4 \3 K! E; A8 |. a* v7 D'画中圈
% R( m4 R" J1 i) WCall ThisDrawing.ModelSpace.AddCircle(centerp, zqr)

'画外框
linep1(0) = centerp(0) - chang / 2
linep1(1) = centerp(1) - kuan / 2
( M% |7 U* `7 ~3 F3 k; g% H9 Wlinep2(0) = centerp(0) + chang / 2
: D( m$ v" x, y1 V* c2 Z* }linep2(1) = centerp(1) + kuan / 2
/ ]. Y" r* i! o+ `: JCall drawbox(linep1, linep2)

ZoomExtents '显示整个图形

: ]  ^. J- o- V  u* b7 oEnd Sub

Private Sub drawbox(p1, p2) '根据对角线坐标画矩形的子程序
Dim boxp(0 To 14) As Double

* x. y9 a  A4 Lboxp(0) = p1(0)
$ n, R$ d- ]: V4 ~boxp(1) = p1(1)

boxp(3) = p1(0)
4 U! k3 N. I+ x7 q7 ~" ^boxp(4) = p2(1)
7 \3 P. n9 V5 {+ {4 b" P, u
boxp(6) = p2(0)
# M( C/ ?: w8 Z4 W8 iboxp(7) = p2(1)

boxp(9) = p2(0)
boxp(10) = p1(1)

. R2 i! u6 I/ t& N. V, R! W5 hboxp(12) = p1(0)
boxp(13) = p1(1)

- a3 A4 E# X4 O% F, MCall ThisDrawing.ModelSpace.AddPolyline(boxp)

End Sub
( F  o0 F: {/ B
& t0 `8 p0 [+ D" p$ n$ r
+ W$ h" n+ u2 P6 J

下面开始分析源码：
$ A7 C  |5 q- i% r8 p3 h
7 ~! B# ~3 P' G1 ?On Error Resume Next
chang = ThisDrawing.Utility.GetReal("长度(90～120)<10500>")
, n) h9 s# Q2 h, `) ?% w& }If Err.Number <> 0 Then '用户输入的不是有效数字
chang = 10500
  U* |4 e( w' |& T0 C  B. xErr.Clear '清除错误
8 l8 E0 o" r; a; i- v1 l  LEnd If
% R! {" T5 U* C; A
    这段代码的作用是要求用户输入一个足球场长度的数字，由于getreal只能输入数字，如果输入其他字符程序就会报错，所以先要用去掉错误提示：On Error Resume Next，虽然错误不再提示，但是出错代码会err.number改变，有兴趣的读者可以用变量跟踪的方法看看这个代码的数值。您只要记住，如果这个数字不是0，那么就是有错了，这时就可以把长度定为默认值，然后用Err.Clear语句把错误代码清零。
% b5 ~* N, m; h7 o
  b& J& R8 I( N2 o. j& B9 B
    在画小禁区的最后一行这样写：Call drawbox(linep1, linep2)

) G' x+ Y8 U7 s6 H" ~% A( g5 F, Z    Drawbox并不是vba提供的方法，它是一个带参数的子程序。由于画足球场要画好几次矩形，
而vba没有提供一个现成的画矩形方法，如果每次都用一长串代码画矩形是很麻烦的，所以需要把这些麻烦的代码写到一个子程序中，在需要时只有写一条调用语句就行了。这个子程序最后几行，从“Private Sub drawbox(p1, p2) ”开始，到end sub结束，p1,p2是参数，调用时也必须写两个参数：linep1、linep2。

0 ]5 V/ {# F3 p6 W. \8 V
ang1 = ThisDrawing.Utility.AngleFromXAxis(linep1, linep3) '计算角度
6 Z6 m9 O7 {" }7 K1 Hang2 = ThisDrawing.Utility.AngleFromXAxis(linep1, linep4)
Call ThisDrawing.ModelSpace.AddArc(linep1, zqr, ang1, ang2) '画弧

4 `7 U! E  Q5 M; W    画圆用addarc方法，需要4个参数：圆心、半径、起始角度、结束角度。AngleFromXAxis用于计算角度，其参数需要两个点坐标
6 I  h6 ~1 J# o( e4 m6 l9 A5 K4 O
下面看镜像操作：
For Each ent In ThisDrawing.ModelSpace '所有模型空间的对象进行一次循环
  If ent.Layer = "足球场" Then '对象在"足球场"图层中
    ent.Mirror linep1, linep2 '镜像
  End If
6 i, D( X2 Z4 E4 E+ ^4 xNext ent

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

8 v+ U9 _, {$ Y  l7 e2 z2 N
( b7 Q8 [. T6 {本课思考题：

1、对本课的例程进行修改，当用户输入长、宽不在规定的范围时要求用户重新输入
6 D3 D6 \# a, I9 P1 B: P
2、设计一张简单的平面图，用户输入2个参数，其他尺寸写进程序中
3 o% w4 a) M+ n$ T2 y8 ]
[ 本帖最后由 tianyunxuan 于 2007-5-26 20:10 编辑 ]

tianyunxuan

定义块方法：
4 ^& Q* q$ c  G* \! m2 Z. m
Set blocksobj=ThisDrawing.Blocks.Add(基点, 块名)
把选择集加入块中的方法：
' V  B" x  d5 [  ~ThisDrawing.CopyObjects(选择集,块)
  M- b( A' r0 c  X8 p' u7 V5 I6 L  G插入块方法：
" J/ g' U" d0 AThisDrawing.ModelSpace.InsertBlock(插入点,块名, X轴比例,Y轴比例,Z轴比例, 旋转角度)
画块属性方法：
ThisDrawing.ModelSpace.AddAttribute(文字高度,模式,提示字符, 插入点, 显示字符,默认值)
9 K; L4 f" _; S8 \% {6 a5 E. n. e3 s一共有五种模式，在输入时会有提示，其中最常用的是“acAttributeModeNormal”普通模式

2 b' }, I0 `5 O! N& z
下面的例题是利用属性块画足球场的阵型图。
程序画出一个球员块，然后把块写到用户指定位置，球员号码由程序自动递增，把球员姓名改为用户输入值。画足球场请参阅上一课内容。

9 b$ S7 M1 ?  x' E4 ?& [- v
6 D% K% B# s/ k% b3 i- v! M+ u

' g0 g& c! f% w, ~# ?0 y

编程思路：
1．定义一个空块
2．在块中画一段弧（球服衣领）
3．画多段线，镜像画出球衣
4 d, z1 ^2 i: M: R; W! L4．画块属性，由于块属性默认的对齐方式是左对齐，而球员号码应该居中，所以必须把块的对齐属性改为居中。但是当这个属性更改时块属性对齐点会自动归零，所以不得不再次更改对齐点属性
$ H8 r1 Y; A( U5．把多段线和属性复制到块中
6．提示用户点选球员位置和姓名
7．插入块，修改球衣号码属性、球员姓名属性

以下是源码，附有详细的注释，如果有疑问，建议用变量跟踪法研究一下。
Sub team()
% q2 W- V! s. U  Q+ T+ W$ R) |Dim playerlay As AcadLayer '定义球员图层
+ D# y: s' y7 j, T1 M1 V5 E* j8 zDim playerblock As AcadBlock '定义块变量
Dim arcc(0 To 2) As Double '圆弧圆心
  }4 |3 r" U6 a: ODim linep1(0 To 2) As Double '线条端点1
Dim linep2(0 To 2) As Double '线条端点2
Dim pline(0 To 20) As Double '定义队服右侧多段线7个顶点
6 C& J6 @' z, B: E! wDim basep(0 To 2) As Double '块基点
Dim playernumberpoint(0 To 2) As Double '块属性插入点
  J- @' @: {5 q" m2 _9 O6 jDim mytxt As AcadTextStyle '定义mytxt变量为文本样式
Dim blockRef As AcadBlockReference '定义块属性变量
0 R8 R: P3 J# r+ K0 SDim Attr3 As Variant '插入块属性变量

Set playerblock = ThisDrawing.Blocks.Add(basep, "球员") '定义一个"球员"的块
% V* l- h3 l  e7 W3 G0 y0 E1 f0 H; G
/ r* a+ l  x5 }+ a& @( V1 Uarcc(0) = 0
arcc(1) = 430
Call playerblock.AddArc(arcc, 50, ThisDrawing.Utility.AngleToReal(180, 0), 0) '画弧并加入块中

pline(0) = 0
9 A, G- u, Q; ~" K: apline(1) = 20
: S4 j3 z. [& O8 }$ r9 j
: T( a( T: V; \pline(3) = 100
pline(4) = 20
3 }# v: k- a) b3 T
& o+ s, T; d0 _2 Opline(6) = 100
pline(7) = 250
2 Z# \0 [' ?4 V  G( E* M6 y
pline(9) = 125
' M. F% J& g: t. t5 B4 p+ Upline(10) = 207

: H8 ]; X& C( V# d, t* Hpline(12) = 212
& e8 q% a% A2 R1 r* F3 ipline(13) = 257


/ _! O( O( E2 [# D4 w- ]7 m4 fpline(15) = 112
pline(16) = 430
6 g  c  n) K- P# |) r
- o) C( r5 t/ M% D3 r2 o% U4 j6 p
pline(18) = 50
pline(19) = 430

Set line1 = ThisDrawing.ModelSpace.AddPolyline(pline) '画队服右侧多段线
8 S3 S6 Y$ g+ b+ l7 E  |$ a
! U/ c% x, h! _; D2 j4 \linep2(1) = 1 '镜像轴第二点位于Y轴上任一点
9 n2 I0 z( g2 ~7 n- x9 @2 u2 I% ?, ?Set line2 = line1.Mirror(linep1, linep2) '镜像获得另一半多段线
/ }5 u: ]$ j! G- I) d
+ F9 N* n4 p. K- ^* c( i7 E5 `Dim p(0 To 2) As Double '定义坐标变量
9 @' K) U; A( M" r- WSet mytxt = ThisDrawing.TextStyles.Add("mytxt") '添加mytxt样式
1 l" }+ E, ?7 t: |" C; Ymytxt.fontFile = "c:\windows\fonts\simfang.ttf" '设置字体文件为仿宋体
. O0 ~5 g* g1 s2 ^' @* ?ThisDrawing.ActiveTextStyle = mytxt '将当前文字样式设置为mytxt

+ n% j8 P0 |' X/ iplayernumberpoint(0) = 0 '块属性位置
playernumberpoint(1) = 200
: p& G$ _$ n; a+ a* m: W( rSet attr1 = ThisDrawing.ModelSpace.AddAttribute(100, acAttributeModeNormal, "号码", playernumberpoint, "X", 0) '画块属性
' r) v9 m; O7 A# P8 t* O9 `attr1.Alignment = 7 '居中
% ~% t% V6 _9 b$ W# n% tattr1.TextAlignmentPoint = playernumberpoint '重定义对齐点
Set attr2 = ThisDrawing.ModelSpace.AddAttribute(100, acAttributeModeNormal, "姓名", playernumberpoint, "???", 0) '画块属性
( p. ^, d( v7 B+ |1 r- Xattr2.Alignment = 7 '居中
# x, _$ h, K6 u6 E' A2 A0 V; H
+ d3 C+ P* I* Q6 [9 E) m
Dim objCollection(0 To 3) As Object '创建选择集
5 a6 y+ U( u2 ^$ y( M' C# \8 o2 ZSet objCollection(0) = line1 '线条1加入选择集
; L3 b9 e( y4 g# I' f: e7 jSet objCollection(1) = line2 '线条2加入选择集
Set objCollection(2) = attr1 '属性1加入选择集
Set objCollection(3) = attr2 '属性2加入选择集

% ]+ a1 }# j9 ]9 wCall ThisDrawing.CopyObjects(objCollection, playerblock) '把选择集加入块中

* H+ ~7 q% a1 c" RFor Each element In objCollection '在选择集中进行循环
  element.Delete '删除线条和属性(此操作并不影响已创建的块)
Next


! i1 |. E' {% w2 Z( I7 dSet playerlay = ThisDrawing.Layers.Add("球员") '新建图层
0 r; p( C; z2 ^5 S3 ^0 kplayerlay.color = 2 '为黄色
6 P0 Y$ \5 g% q0 C! DThisDrawing.ActiveLayer = playerlay '将当前图层设置为球员图层
" Z# j, L4 r. o3 `
Dim p1 As Variant '块插入点位置
+ b; ^3 v7 W# n! y0 x$ r1 k
. j4 ~& J/ ~; }& QFor i = 1 To 11 '插入块
  pstring = CStr(i) & "号球员位置："
% {" ]* d, ?" Q/ }( K  p1 = ThisDrawing.Utility.GetPoint(, pstring) '点选球员位置坐标
& ?6 J- G3 C" w4 x  P1 n6 g  nstring = ThisDrawing.Utility.GetString(30, "球员姓名：")
% _3 a1 g1 \/ K  Set blockRef = ThisDrawing.ModelSpace.InsertBlock(p1, "球员", 1, 1, 1, 0) '插入块
  Attr3 = blockRef.GetAttributes '获取块属性
  Attr3(0).TextString = CStr(i) '赋值球员号码
  Attr3(1).TextString = nstring '赋值球员姓名
Next
$ `6 s" e% L$ [& W$ p8 y5 ]
End Sub
% G$ ]! P8 N" i
本课思考题：
2 J- L" t! G# l# l6 C1、在本课例程的最后一段增加出错陷阱代码，当用户输入非正常数值时退出程序
8 F7 @$ g7 E8 o0 I0 ~% [2、画一个简易路灯块，用属性块做为路灯编号，由用户点选路灯位置，程序画路灯时自动为路灯编号

trinco

很有帮助！谢谢lz

cgc

终于看好了，写得很不错， 连我从来不写程序的人都能看得懂了
, g1 X: g( x7 ?0 ]1 {( p# b
好好学习，感觉函数 方面还有很多的东西不是很懂
  Z0 S8 n3 v& q! C) b* e
有函数库可以查阅么？
6 Q# z8 Z/ M; S0 l6 f+ l3 J# `0 C0 X
8 `. Y5 d% J# q0 x: Z2 C3 u买书也行

nebs

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

lianghn1986

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

pianpi111

auto cad vba第一次听说
学学

nebs

顶！！ 学习中.....

sod11791

太难了，能学会吗？

kyokula

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