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

pengyg1204

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

wangpiwujing

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

yhfsmu

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

设计从零

支持楼主！！！
！

hellmen

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

tianyunxuan

简单地讲，参数化设计就是根据参数进行精确绘图，绘图所需要的参数也可以由用户手工输入。真正的参数化设计往往需要数据库操作，为了简化程序，把数据库部分放在以后的课程中详细讲解。
6 N$ N* U' |* S6 V* S( p2 T5 p: s
, A- E! C5 I8 x/ n- J$ I+ p1 \    本课的例程是画一个标准足球场。足球场长度90～120米，宽度45～90米，而红色标注的尺寸是程序默认的，绿色标注固定不变。
5 g3 i6 c9 g6 `, E4 Y
) V* N$ F' S; X$ j3 ~2 ]  G; ~

4 V; e- o2 K. L- c8 S8 a6 J3 W
Sub court()
Dim courtlay As AcadLayer '定义球场图层
4 \/ v+ _8 K, H& S  rDim ent As AcadEntity '镜像对象
: s- s0 Q0 s0 E+ v& bDim linep1(0 To 2) As Double '线条端点1
- Z( y' N7 r% l2 K% n1 ADim linep2(0 To 2) As Double '线条端点2
. W% O0 v% n2 |Dim linep3(0 To 2) As Double '罚球弧端点1
( E4 c$ V- U; M- LDim linep4(0 To 2) As Double '罚球弧端点2
Dim centerp As Variant '中心坐标
xjq = 11000 '小禁区尺寸
" Q7 w; G+ u- [5 D( ^$ A# }djq = 33000 '大禁区尺寸
) m5 N7 n6 `3 D& K9 q% Efqd = 11000 '罚球点位置
fqr = 9150 '罚球弧半径
fqh = 14634.98 '罚球弧弦长
: H7 b$ `3 B( i: d$ v4 b1 S9 a+ kjqqr = 1000 '角球区半径
. }2 f! B5 P  P6 J) Lzqr = 9150 '中圈半径
+ w- b1 c; k& e: w, Q$ r. ?
On Error Resume Next
chang = ThisDrawing.Utility.GetReal("长度(90000～120000)<105000>")
% l7 I5 u. P1 @( {If Err.Number <> 0 Then '用户输入的不是有效数字
* R/ Q9 M  H7 e' }  chang = 105000
5 i/ @$ X# {' \0 i* X0 m9 p  s  Err.Clear '清除错误
" P5 |- _! S! t, D+ m4 K; d# yEnd If
4 t: Y% E  R2 b+ j; h3 Kkuan = ThisDrawing.Utility.GetReal("宽度(45000～90000)<68000>")
+ O8 t( s  r" d2 v5 o* WIf Err.Number <> 0 Then
8 k% d1 ~. o$ [  kuan = 68000
) J7 u3 Y7 T# z: p. dEnd If
6 a  o% y- e7 p0 g& R2 m- k3 |
# g4 d0 F2 k' [4 R' i6 r; \centerp = ThisDrawing.Utility.GetPoint(, "定位球场中心:")

Set courtlay = ThisDrawing.Layers.Add("足球场") '设置图层
% O1 f5 b; O# hThisDrawing.ActiveLayer = courtlay '把当前图层设为足球场图层

* ^8 o1 e; s; N% c+ J'画小禁区
linep1(0) = centerp(0) + chang / 2
4 G1 c! n# G2 r+ v, \4 Jlinep1(1) = centerp(1) + xjq / 2
linep2(0) = centerp(0) + chang / 2 - xjq / 2
& Y8 j2 D' g+ p' u+ Q- Glinep2(1) = centerp(1) - xjq / 2
Call drawbox(linep1, linep2) '调用画矩形子程序

8 w8 A" v$ r9 `: n5 h( A: n
1 C! i, [: {% L6 D  i9 w9 H/ s4 ~
'画大禁区
linep1(0) = centerp(0) + chang / 2
: Y. m5 E* B- z: Klinep1(1) = centerp(1) + djq / 2
7 o9 B' `4 k. P/ w6 h6 ]linep2(0) = centerp(0) + chang / 2 - djq / 2
3 U" h" G& W6 K( T. ulinep2(1) = centerp(1) - djq / 2
Call drawbox(linep1, linep2)
8 [# `$ T- f3 H$ m, Y) G& O

' 画罚球点
$ |7 H7 g) r3 ulinep1(0) = centerp(0) + chang / 2 - fqd
0 r3 b, \, v9 x6 r- T8 klinep1(1) = centerp(1)
Call ThisDrawing.ModelSpace.AddPoint(linep1)
4 z" [/ I8 [8 D- D0 o8 H# ^'ThisDrawing.SetVariable "PDMODE", 32 '点样式
ThisDrawing.SetVariable "PDSIZE", 30 '点的尺寸

'画罚球弧，罚球弧圆心就是罚球点linep1
linep3(0) = centerp(0) + chang / 2 - djq / 2
linep3(1) = centerp(1) + fqh / 2
linep4(0) = linep3(0) '两个端点的x轴相同
linep4(1) = centerp(1) - fqh / 2
9 Z3 s- U! a8 I' a5 ]ang1 = ThisDrawing.Utility.AngleFromXAxis(linep1, linep3) '计算角度
/ Z; W# d! \, `+ P0 ], H) oang2 = ThisDrawing.Utility.AngleFromXAxis(linep1, linep4)
Call ThisDrawing.ModelSpace.AddArc(linep1, zqr, ang1, ang2) '画弧

/ M/ Q& t& i5 K
/ c6 F' E$ L1 f: f, S8 |5 c'角球弧
ang1 = ThisDrawing.Utility.AngleToReal(90, 0) '角度转换为弧度
' }9 V! }  g8 E9 e* E3 }ang2 = ThisDrawing.Utility.AngleToReal(180, 0)
0 d# W& M" x6 `6 A  q4 F7 ]" G( I& Dlinep1(0) = centerp(0) + chang / 2 '角球弧圆心
linep1(1) = centerp(1) - kuan / 2
+ G) w& i+ X4 Y" cCall ThisDrawing.ModelSpace.AddArc(linep1, jqqr, ang1, ang2) '画弧
" `' l7 M: T7 }5 \- g: u
" _0 F; r1 y  n, G& Xang1 = ThisDrawing.Utility.AngleToReal(270, 0)
3 v* i" ]( @; v% P' ~linep1(1) = centerp(1) + kuan / 2
3 d* ~. M. I8 C9 h8 {, D% lCall ThisDrawing.ModelSpace.AddArc(linep1, jqqr, ang2, ang1)

& O1 j0 \& n6 x

& X7 z2 R4 E! a: v. M) }'镜像轴
linep1(0) = centerp(0)
linep1(1) = centerp(1) - kuan / 2
linep2(0) = centerp(0)
  }. P+ n; A% ~6 ^linep2(1) = centerp(1) + kuan / 2
/ ]" ~% }) k7 {8 o# {4 G1 _
'镜像
For Each ent In ThisDrawing.ModelSpace '所有模型空间的对象进行一次循环
  If ent.Layer = "足球场" Then '对象在"足球场"图层中
2 m. Y* L2 u, i4 l  o    ent.Mirror linep1, linep2 '镜像
  End If
Next ent
! g6 [! q3 z* x1 s5 _
'画中线
0 ?! O- Y. q7 O' PCall ThisDrawing.ModelSpace.AddLine(linep1, linep2)
9 o1 Z/ r" `! L9 n% l2 {4 I
'画中圈
- r7 }3 a  e  ~# A$ E! ICall ThisDrawing.ModelSpace.AddCircle(centerp, zqr)

'画外框
linep1(0) = centerp(0) - chang / 2
: L7 f# d! r0 Wlinep1(1) = centerp(1) - kuan / 2
9 f2 i7 v& m% p* `/ h" Tlinep2(0) = centerp(0) + chang / 2
linep2(1) = centerp(1) + kuan / 2
Call drawbox(linep1, linep2)
" H# l9 J0 X9 `+ u" j( @; V
ZoomExtents '显示整个图形

0 I- p  n+ ]2 B  c" Z* h6 f! i% WEnd Sub
: C) K. H, c4 T/ N0 B5 Y" a' W
4 {5 P  P4 w! n" b0 _: Z' V  IPrivate Sub drawbox(p1, p2) '根据对角线坐标画矩形的子程序
Dim boxp(0 To 14) As Double

1 \5 i) ~; u8 u+ Dboxp(0) = p1(0)
: i# N! _0 S8 {+ zboxp(1) = p1(1)
) L- f7 \% W6 }
3 W3 [, Z. s9 N" iboxp(3) = p1(0)
3 v1 a8 J8 \  H; ]; @boxp(4) = p2(1)
/ b! f. O! i/ L; a( C
8 D- L5 y+ K! w7 ?  ]5 aboxp(6) = p2(0)
3 F1 g1 j& X) l8 Vboxp(7) = p2(1)
/ Z; |7 X* u! r4 m. N2 W
boxp(9) = p2(0)
boxp(10) = p1(1)

5 P2 I5 w9 w# t& h2 H( rboxp(12) = p1(0)
boxp(13) = p1(1)
7 A$ Y5 y! S  V
Call ThisDrawing.ModelSpace.AddPolyline(boxp)

End Sub
& H7 \! h: E* d0 i. v2 K
( _- ]+ e8 f/ A! C  E" a8 q


* t8 e$ U2 b  S. c) g, I下面开始分析源码：

; P% @8 t  Q( oOn Error Resume Next
" h" n0 @3 t5 R( ]/ [chang = ThisDrawing.Utility.GetReal("长度(90～120)<10500>")
If Err.Number <> 0 Then '用户输入的不是有效数字
7 _( w- {( ~4 D: b0 ?: Wchang = 10500
5 R8 K+ z0 v& nErr.Clear '清除错误
" t+ S  Y' m, EEnd If

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

" [# {. N2 }- E    在画小禁区的最后一行这样写：Call drawbox(linep1, linep2)
! C. J7 R, z+ E- Q: R
    Drawbox并不是vba提供的方法，它是一个带参数的子程序。由于画足球场要画好几次矩形，
: \; t' W! [1 R- J+ b3 E; K而vba没有提供一个现成的画矩形方法，如果每次都用一长串代码画矩形是很麻烦的，所以需要把这些麻烦的代码写到一个子程序中，在需要时只有写一条调用语句就行了。这个子程序最后几行，从“Private Sub drawbox(p1, p2) ”开始，到end sub结束，p1,p2是参数，调用时也必须写两个参数：linep1、linep2。


" b. P2 C, R) T8 e; |( {* k, lang1 = ThisDrawing.Utility.AngleFromXAxis(linep1, linep3) '计算角度
ang2 = ThisDrawing.Utility.AngleFromXAxis(linep1, linep4)
Call ThisDrawing.ModelSpace.AddArc(linep1, zqr, ang1, ang2) '画弧
! B+ e: W. c6 h
    画圆用addarc方法，需要4个参数：圆心、半径、起始角度、结束角度。AngleFromXAxis用于计算角度，其参数需要两个点坐标
# K) `2 ~3 u! ~
, v) J' R8 b) [( \) a( M$ m  y# p下面看镜像操作：
For Each ent In ThisDrawing.ModelSpace '所有模型空间的对象进行一次循环
  If ent.Layer = "足球场" Then '对象在"足球场"图层中
    ent.Mirror linep1, linep2 '镜像
& t% X! g8 P1 u$ G# m  End If
$ W% r; e* J2 W# ZNext ent
$ W- l" t! s9 \/ o
    本例只对“足球场”图层中的对象进行镜像，所以要对全部对象进行循环，判断对象的图层属性，只有位于“足球场”图层中的对象才作镜像。


* [% ?8 q0 j- V. S3 q本课思考题：
: `+ F, a0 f. J) B; @
  \) [& K0 ]/ T" Q# L+ A1、对本课的例程进行修改，当用户输入长、宽不在规定的范围时要求用户重新输入
& X5 G! E; S) d& Z9 |& Q
- n. p# ?& `/ z, @" I2、设计一张简单的平面图，用户输入2个参数，其他尺寸写进程序中

# D+ ]; a( |) u4 R: e. i[ 本帖最后由 tianyunxuan 于 2007-5-26 20:10 编辑 ]

tianyunxuan

定义块方法：

2 S: h  A  _6 _: r6 Q" `( \( gSet blocksobj=ThisDrawing.Blocks.Add(基点, 块名)
把选择集加入块中的方法：
+ H( N) h! R* q0 C  tThisDrawing.CopyObjects(选择集,块)
: [: B+ N! @! k7 ^3 {. J插入块方法：
ThisDrawing.ModelSpace.InsertBlock(插入点,块名, X轴比例,Y轴比例,Z轴比例, 旋转角度)
画块属性方法：
ThisDrawing.ModelSpace.AddAttribute(文字高度,模式,提示字符, 插入点, 显示字符,默认值)
/ C$ j7 I+ |$ H9 R一共有五种模式，在输入时会有提示，其中最常用的是“acAttributeModeNormal”普通模式
6 d, _) q/ L0 K6 L$ W8 E
& @# e% a2 y( b8 W: F' d
5 \! Q8 A/ `( T* h. Z# O下面的例题是利用属性块画足球场的阵型图。
# ^( F! Y9 V6 S' t8 S  O6 z4 i! `程序画出一个球员块，然后把块写到用户指定位置，球员号码由程序自动递增，把球员姓名改为用户输入值。画足球场请参阅上一课内容。

0 ^' E) W1 G# ~  d. Y- ?; s: a- ?
( @3 D& A8 U  U$ _1 F/ f8 d


9 _9 x8 \+ I1 V1 Y4 R
编程思路：
; l' k& `+ k. h( S1．定义一个空块
2．在块中画一段弧（球服衣领）
3．画多段线，镜像画出球衣
' Y8 g! F4 p2 c6 u5 f4．画块属性，由于块属性默认的对齐方式是左对齐，而球员号码应该居中，所以必须把块的对齐属性改为居中。但是当这个属性更改时块属性对齐点会自动归零，所以不得不再次更改对齐点属性
9 t. g1 f" I% F+ g' ?! f. t5 R5．把多段线和属性复制到块中
6．提示用户点选球员位置和姓名
7．插入块，修改球衣号码属性、球员姓名属性
  r2 g& H8 I- j! h( z9 `! Z
* O" r" D) \2 B8 I以下是源码，附有详细的注释，如果有疑问，建议用变量跟踪法研究一下。
Sub team()
Dim playerlay As AcadLayer '定义球员图层
Dim playerblock As AcadBlock '定义块变量
+ ~" N  V- t3 b6 q; U5 S# LDim arcc(0 To 2) As Double '圆弧圆心
Dim linep1(0 To 2) As Double '线条端点1
7 ~, }8 E' c: o9 B; wDim 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 '块属性插入点
" K: J" x$ n5 T$ h" `' WDim mytxt As AcadTextStyle '定义mytxt变量为文本样式
- o6 v/ M; j7 a  C6 J. fDim blockRef As AcadBlockReference '定义块属性变量
Dim Attr3 As Variant '插入块属性变量
1 ^) t8 P! c3 s) o: u
$ a4 s( h: ]! [0 D. A% RSet playerblock = ThisDrawing.Blocks.Add(basep, "球员") '定义一个"球员"的块
$ g  f! f% t) V5 y. F  b
arcc(0) = 0
& r2 ]; m- N" y" }& [: K2 j3 d) e  aarcc(1) = 430
Call playerblock.AddArc(arcc, 50, ThisDrawing.Utility.AngleToReal(180, 0), 0) '画弧并加入块中

pline(0) = 0
pline(1) = 20
6 d2 g( S* l4 x* s3 L: _# v$ E8 k) [
( n# @: G" ^: {5 Z5 Tpline(3) = 100
pline(4) = 20
8 C. X7 m( R8 R* s  `' e6 [- I" O
pline(6) = 100
pline(7) = 250

pline(9) = 125
pline(10) = 207
( h1 H/ N" x. q& f% @
# ?; V! m6 J# Y, {4 F7 s6 Ipline(12) = 212
, h) b1 K! N4 B1 W9 m& F; o3 D% B' Epline(13) = 257
2 k( |3 p2 t) A! X5 l
9 \3 q5 T0 G. |
pline(15) = 112
2 I4 h/ A2 C: |* U  qpline(16) = 430

+ R7 i& W. T) i) d9 m
pline(18) = 50
pline(19) = 430

Set line1 = ThisDrawing.ModelSpace.AddPolyline(pline) '画队服右侧多段线

* Q/ u, N' h  slinep2(1) = 1 '镜像轴第二点位于Y轴上任一点
Set line2 = line1.Mirror(linep1, linep2) '镜像获得另一半多段线

Dim p(0 To 2) As Double '定义坐标变量
& j6 b" M- \3 ~/ ^- `7 fSet mytxt = ThisDrawing.TextStyles.Add("mytxt") '添加mytxt样式
mytxt.fontFile = "c:\windows\fonts\simfang.ttf" '设置字体文件为仿宋体
( Q8 [3 N: c: g8 gThisDrawing.ActiveTextStyle = mytxt '将当前文字样式设置为mytxt

! W  n8 Q7 B/ S/ ^8 j  R$ I1 |playernumberpoint(0) = 0 '块属性位置
9 t8 {( e( m! v1 \. kplayernumberpoint(1) = 200
Set attr1 = ThisDrawing.ModelSpace.AddAttribute(100, acAttributeModeNormal, "号码", playernumberpoint, "X", 0) '画块属性
attr1.Alignment = 7 '居中
attr1.TextAlignmentPoint = playernumberpoint '重定义对齐点
3 |% X- f6 }' M$ ]& E) C, z# XSet attr2 = ThisDrawing.ModelSpace.AddAttribute(100, acAttributeModeNormal, "姓名", playernumberpoint, "???", 0) '画块属性
! E3 k' c' c( j8 P2 C& Wattr2.Alignment = 7 '居中
" c: s3 H2 n) c) }3 f3 K
+ [& |# S' E* g) b
- B. ~; l+ y2 V7 B4 e9 zDim objCollection(0 To 3) As Object '创建选择集
Set objCollection(0) = line1 '线条1加入选择集
Set objCollection(1) = line2 '线条2加入选择集
9 j8 h& K" |7 e/ I: w+ JSet objCollection(2) = attr1 '属性1加入选择集
) ]) c5 k  |) L# xSet objCollection(3) = attr2 '属性2加入选择集
8 }2 ~$ H/ z# ]! Q  u0 C
Call ThisDrawing.CopyObjects(objCollection, playerblock) '把选择集加入块中

; m; A" P8 a) @6 r9 [6 OFor Each element In objCollection '在选择集中进行循环
- \. K+ x  o1 H" x) o6 h6 s  ~; q  element.Delete '删除线条和属性(此操作并不影响已创建的块)
7 J% z" r( u0 aNext
$ _$ i% I; Z! O7 Z: P5 R3 A
( v0 N) H$ e4 a
# G. j* e1 a6 Z% b' d: x/ PSet playerlay = ThisDrawing.Layers.Add("球员") '新建图层
6 {- y1 J/ J: F( j0 d9 m; }' `playerlay.color = 2 '为黄色
ThisDrawing.ActiveLayer = playerlay '将当前图层设置为球员图层
/ _/ L4 @/ V/ {( P& d
Dim p1 As Variant '块插入点位置

For i = 1 To 11 '插入块
. q9 q) E* ?+ H% `. R  pstring = CStr(i) & "号球员位置："
" V- x, ]. n$ @* \9 J, j8 i6 M  p1 = ThisDrawing.Utility.GetPoint(, pstring) '点选球员位置坐标
  nstring = ThisDrawing.Utility.GetString(30, "球员姓名：")
% R! D) F3 d( i& Z; q6 b: A  Set blockRef = ThisDrawing.ModelSpace.InsertBlock(p1, "球员", 1, 1, 1, 0) '插入块
  Attr3 = blockRef.GetAttributes '获取块属性
  Attr3(0).TextString = CStr(i) '赋值球员号码
  Attr3(1).TextString = nstring '赋值球员姓名
" o7 t+ J( x. B; {6 R- ONext
) I- G1 T3 ]0 _8 s2 Q& c
* f1 K: _$ X5 P& Z# j! _End Sub

+ B9 B8 p$ ]/ u( i) A* [, e本课思考题：
, U* ~& V5 ?* h; V1、在本课例程的最后一段增加出错陷阱代码，当用户输入非正常数值时退出程序
' v  c$ `- t7 `2 u2 T. Y2、画一个简易路灯块，用属性块做为路灯编号，由用户点选路灯位置，程序画路灯时自动为路灯编号

trinco

很有帮助！谢谢lz

cgc

终于看好了，写得很不错， 连我从来不写程序的人都能看得懂了
  A; T, ~6 k  O
好好学习，感觉函数 方面还有很多的东西不是很懂

, q; N- m0 x% `0 A有函数库可以查阅么？
0 ]* `, U1 j! q" t' ^! J
) e0 E2 y8 M- D! L9 F买书也行

nebs

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

lianghn1986

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

pianpi111

auto cad vba第一次听说
# s( i# z) p, H5 f3 E) E学学

nebs

顶！！ 学习中.....

sod11791

太难了，能学会吗？

kyokula

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