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

pengyg1204

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

wangpiwujing

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

yhfsmu

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

设计从零

支持楼主！！！
8 W3 F* T: {: k+ V！

hellmen

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

tianyunxuan

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

    本课的例程是画一个标准足球场。足球场长度90～120米，宽度45～90米，而红色标注的尺寸是程序默认的，绿色标注固定不变。
7 K; k! {. K8 L2 V- _6 j" k



Sub court()
( b6 U) q% E! z3 Z* IDim courtlay As AcadLayer '定义球场图层
; h! F' V  a: J) |# [Dim ent As AcadEntity '镜像对象
, Q" h3 W7 G  q& s% HDim linep1(0 To 2) As Double '线条端点1
Dim linep2(0 To 2) As Double '线条端点2
: H- R0 s# m9 N8 bDim linep3(0 To 2) As Double '罚球弧端点1
Dim linep4(0 To 2) As Double '罚球弧端点2
! ]! X) B% z/ l  N- Q. v3 FDim centerp As Variant '中心坐标
xjq = 11000 '小禁区尺寸
djq = 33000 '大禁区尺寸
fqd = 11000 '罚球点位置
fqr = 9150 '罚球弧半径
fqh = 14634.98 '罚球弧弦长
- L) d; u9 J, s% t4 Ejqqr = 1000 '角球区半径
zqr = 9150 '中圈半径
, R8 r; B5 D% h4 l
On Error Resume Next
2 W. F$ M0 r3 c- Vchang = ThisDrawing.Utility.GetReal("长度(90000～120000)<105000>")
: J* E- }2 }5 |: m' b6 sIf Err.Number <> 0 Then '用户输入的不是有效数字
' g  `+ o% x1 s1 ?! Z% m" A* |) Q  chang = 105000
  Err.Clear '清除错误
% e" B4 @1 f" _( r5 R' }1 E/ Q8 LEnd If
3 x4 |0 a& Z1 Jkuan = ThisDrawing.Utility.GetReal("宽度(45000～90000)<68000>")
+ D2 e% D) A6 m+ X5 PIf Err.Number <> 0 Then
1 ]6 a8 T& E' I, s/ I  kuan = 68000
End If
5 `- u. }' _# a( S) X1 W
" l% }* z& M* X) R" O9 A0 \centerp = ThisDrawing.Utility.GetPoint(, "定位球场中心:")

Set courtlay = ThisDrawing.Layers.Add("足球场") '设置图层
( B* W* G6 Q$ F: jThisDrawing.ActiveLayer = courtlay '把当前图层设为足球场图层
4 P! A. F6 t6 V9 o1 J% x4 `
'画小禁区
& m2 n' e# ?1 k& `linep1(0) = centerp(0) + chang / 2
. H( O( B' v& Z# A! c3 Glinep1(1) = centerp(1) + xjq / 2
linep2(0) = centerp(0) + chang / 2 - xjq / 2
linep2(1) = centerp(1) - xjq / 2
. z% Z4 N/ W* E$ j. QCall drawbox(linep1, linep2) '调用画矩形子程序


7 k% O+ l8 j: y
'画大禁区
% U, @; X9 p9 Y% d/ T$ B# T5 Dlinep1(0) = centerp(0) + chang / 2
7 Z" Q& o% V: \1 O1 O  O/ e: W5 n( xlinep1(1) = centerp(1) + djq / 2
- C* q5 R& X8 h' b; L& Q' Klinep2(0) = centerp(0) + chang / 2 - djq / 2
linep2(1) = centerp(1) - djq / 2
Call drawbox(linep1, linep2)


, j; @, h7 Q3 X+ l% S' 画罚球点
6 W0 T' m8 a# p) W* l/ S8 V" llinep1(0) = centerp(0) + chang / 2 - fqd
; B% x, R8 w- R( d2 _% X; Elinep1(1) = centerp(1)
& y& I. }1 M1 ?$ BCall ThisDrawing.ModelSpace.AddPoint(linep1)
0 O: `5 v6 `2 \0 @! w. u'ThisDrawing.SetVariable "PDMODE", 32 '点样式
ThisDrawing.SetVariable "PDSIZE", 30 '点的尺寸

'画罚球弧，罚球弧圆心就是罚球点linep1
linep3(0) = centerp(0) + chang / 2 - djq / 2
0 @4 O; N! \! r+ m( R  U3 k2 Z" ~linep3(1) = centerp(1) + fqh / 2
linep4(0) = linep3(0) '两个端点的x轴相同
1 l, T( E4 b7 S) L, b/ [4 olinep4(1) = centerp(1) - fqh / 2
% h8 ^0 d- h/ Z2 k% V# m/ r0 \ang1 = ThisDrawing.Utility.AngleFromXAxis(linep1, linep3) '计算角度
ang2 = ThisDrawing.Utility.AngleFromXAxis(linep1, linep4)
Call ThisDrawing.ModelSpace.AddArc(linep1, zqr, ang1, ang2) '画弧
% c( s8 M. Q! x' J6 O' {

, {" e0 i6 N) T# Y3 J'角球弧
# s8 [0 A- b4 L( |/ `2 Lang1 = ThisDrawing.Utility.AngleToReal(90, 0) '角度转换为弧度
ang2 = ThisDrawing.Utility.AngleToReal(180, 0)
linep1(0) = centerp(0) + chang / 2 '角球弧圆心
linep1(1) = centerp(1) - kuan / 2
. `% z6 E, I' j7 GCall ThisDrawing.ModelSpace.AddArc(linep1, jqqr, ang1, ang2) '画弧
6 Y/ K, x+ }1 e3 y0 [% q3 \; G3 }
9 ?( X. B1 w8 wang1 = ThisDrawing.Utility.AngleToReal(270, 0)
0 |) l% \& O2 H9 qlinep1(1) = centerp(1) + kuan / 2
3 B  G4 g6 X3 l. _/ s. aCall ThisDrawing.ModelSpace.AddArc(linep1, jqqr, ang2, ang1)
& J3 M: g" g+ |
* S0 y9 P+ Q' E, ]9 C' Q6 s4 C

3 A% M2 b2 w$ Z  `% v( j- l" Q& e'镜像轴
1 C/ _/ ]0 ]; l5 W; I9 Jlinep1(0) = centerp(0)
& l/ y& n4 R: P& Jlinep1(1) = centerp(1) - kuan / 2
: l7 D& a2 h' y5 ]; O1 \5 M) V6 llinep2(0) = centerp(0)
linep2(1) = centerp(1) + kuan / 2

# |. v; G: n! g7 v  F2 p* ~'镜像
For Each ent In ThisDrawing.ModelSpace '所有模型空间的对象进行一次循环
4 B+ Y* q, C% }- [  If ent.Layer = "足球场" Then '对象在"足球场"图层中
) v9 F: U  I) i% [5 O; Y    ent.Mirror linep1, linep2 '镜像
  End If
2 \# X, ^- n3 k& p7 H# T' BNext ent
5 {0 r5 B3 ~5 x7 Q  F3 N
  l2 Q  ]7 u; d/ ['画中线
2 f2 ?! @5 n( ICall ThisDrawing.ModelSpace.AddLine(linep1, linep2)
+ a& r' D2 g( M. t
'画中圈
8 T& [5 ~3 @' L  S7 v( Z2 |0 `Call ThisDrawing.ModelSpace.AddCircle(centerp, zqr)

'画外框
) ~0 ~  Q/ b' I+ d  B  hlinep1(0) = centerp(0) - chang / 2
' d/ U: w0 `% M/ ~- ]linep1(1) = centerp(1) - kuan / 2
6 N) H( ^: r% Elinep2(0) = centerp(0) + chang / 2
0 A( f8 d( U1 G$ Elinep2(1) = centerp(1) + kuan / 2
. b: \0 g4 {- @! _3 i" W9 B, HCall drawbox(linep1, linep2)

3 Q# `) k5 B2 I6 W3 AZoomExtents '显示整个图形
: w+ |7 g9 A9 L( v3 j
End Sub

Private Sub drawbox(p1, p2) '根据对角线坐标画矩形的子程序
Dim boxp(0 To 14) As Double
/ o1 `2 g: L, N* T  C1 n
boxp(0) = p1(0)
7 e+ K4 r7 Z/ E% P* bboxp(1) = p1(1)
$ g' O) j& j$ H5 T6 D' C
' ~4 j) ~# ^0 B- Q  Vboxp(3) = p1(0)
boxp(4) = p2(1)
" x$ a9 J1 m' o
boxp(6) = p2(0)
boxp(7) = p2(1)

boxp(9) = p2(0)
8 X: A# B( n' i5 s+ rboxp(10) = p1(1)
( `+ ]/ \2 d5 |, e% A7 N
boxp(12) = p1(0)
boxp(13) = p1(1)
2 f* o/ R' N. y/ c7 Q
% [" q$ E' g! k! N; U& ACall ThisDrawing.ModelSpace.AddPolyline(boxp)
8 M9 D6 J2 [3 u8 d
5 Q9 J- U% u* L  z: fEnd Sub
) p, b+ `2 u3 M! s& [! _' B& V


  o4 P5 q: [6 q0 m( N. P9 O. W
/ f' `$ D7 ^' ]+ n- D  X下面开始分析源码：

On Error Resume Next
/ F9 T9 B' b( U" q; mchang = ThisDrawing.Utility.GetReal("长度(90～120)<10500>")
! G' W+ q1 i# |5 UIf Err.Number <> 0 Then '用户输入的不是有效数字
' {6 t' g& |& o/ fchang = 10500
Err.Clear '清除错误
End If
8 J2 v7 b  ]2 N5 q! \4 B
/ O5 M7 Y- @$ ~0 k) b4 M    这段代码的作用是要求用户输入一个足球场长度的数字，由于getreal只能输入数字，如果输入其他字符程序就会报错，所以先要用去掉错误提示：On Error Resume Next，虽然错误不再提示，但是出错代码会err.number改变，有兴趣的读者可以用变量跟踪的方法看看这个代码的数值。您只要记住，如果这个数字不是0，那么就是有错了，这时就可以把长度定为默认值，然后用Err.Clear语句把错误代码清零。
! Z/ X' J9 `/ H/ V, A$ g! i
+ P2 X3 r' n8 d6 v: V) o
    在画小禁区的最后一行这样写：Call drawbox(linep1, linep2)

    Drawbox并不是vba提供的方法，它是一个带参数的子程序。由于画足球场要画好几次矩形，
9 X) P$ F1 @* Y1 L7 `* N1 b而vba没有提供一个现成的画矩形方法，如果每次都用一长串代码画矩形是很麻烦的，所以需要把这些麻烦的代码写到一个子程序中，在需要时只有写一条调用语句就行了。这个子程序最后几行，从“Private Sub drawbox(p1, p2) ”开始，到end sub结束，p1,p2是参数，调用时也必须写两个参数：linep1、linep2。
; \9 C+ W8 e1 F

* `3 s: x6 q/ ?5 ?ang1 = ThisDrawing.Utility.AngleFromXAxis(linep1, linep3) '计算角度
8 ~, f: }3 Z$ B$ l: K3 ^ang2 = ThisDrawing.Utility.AngleFromXAxis(linep1, linep4)
Call ThisDrawing.ModelSpace.AddArc(linep1, zqr, ang1, ang2) '画弧
$ {4 C7 k( ?( f, V4 a3 g4 Z, m9 q
    画圆用addarc方法，需要4个参数：圆心、半径、起始角度、结束角度。AngleFromXAxis用于计算角度，其参数需要两个点坐标

4 ]" [' Y; J# l: f4 P下面看镜像操作：
For Each ent In ThisDrawing.ModelSpace '所有模型空间的对象进行一次循环
  If ent.Layer = "足球场" Then '对象在"足球场"图层中
    ent.Mirror linep1, linep2 '镜像
# E& e3 l% f  F0 ^( h9 Y5 k; U  End If
: A+ t0 ^  ]: f7 fNext ent

    本例只对“足球场”图层中的对象进行镜像，所以要对全部对象进行循环，判断对象的图层属性，只有位于“足球场”图层中的对象才作镜像。
* k6 |8 b( [6 R' f

本课思考题：

8 g( }% e! r+ J3 h+ q1、对本课的例程进行修改，当用户输入长、宽不在规定的范围时要求用户重新输入
7 T2 @0 S2 }2 [" C% O
2、设计一张简单的平面图，用户输入2个参数，其他尺寸写进程序中
) o- T* `; ?; b+ b, m3 y
[ 本帖最后由 tianyunxuan 于 2007-5-26 20:10 编辑 ]

tianyunxuan

定义块方法：

Set blocksobj=ThisDrawing.Blocks.Add(基点, 块名)
把选择集加入块中的方法：
ThisDrawing.CopyObjects(选择集,块)
插入块方法：
8 c, |9 Q# @2 U3 G+ L1 eThisDrawing.ModelSpace.InsertBlock(插入点,块名, X轴比例,Y轴比例,Z轴比例, 旋转角度)
画块属性方法：
ThisDrawing.ModelSpace.AddAttribute(文字高度,模式,提示字符, 插入点, 显示字符,默认值)
! _% A( V' V' G- V* X. B+ A) w2 I一共有五种模式，在输入时会有提示，其中最常用的是“acAttributeModeNormal”普通模式
# A5 N, ~* g, W& ?' J+ {* r
6 A1 R8 q- x* A# H7 t
! j/ H5 }3 z- r下面的例题是利用属性块画足球场的阵型图。
程序画出一个球员块，然后把块写到用户指定位置，球员号码由程序自动递增，把球员姓名改为用户输入值。画足球场请参阅上一课内容。



" U) g& t& R3 n7 o

0 f6 G2 ^/ k' v0 V) A
编程思路：
# [9 d/ Z; _+ i# u; o; w( E1．定义一个空块
2．在块中画一段弧（球服衣领）
% A. b# y8 l* S. L! e) z. L0 ~0 k3．画多段线，镜像画出球衣
" t3 T  g: e% e$ e8 g- W- c" a, V7 Z4．画块属性，由于块属性默认的对齐方式是左对齐，而球员号码应该居中，所以必须把块的对齐属性改为居中。但是当这个属性更改时块属性对齐点会自动归零，所以不得不再次更改对齐点属性
$ j. m. w9 u) k; p5 y+ v8 ?5．把多段线和属性复制到块中
6．提示用户点选球员位置和姓名
) R  P3 e9 _% u7．插入块，修改球衣号码属性、球员姓名属性
3 @  T; s1 _% M3 A+ k; v9 \
# ]9 u- B. T& S. _以下是源码，附有详细的注释，如果有疑问，建议用变量跟踪法研究一下。
4 N* K& Q+ `, ]4 P% SSub team()
Dim playerlay As AcadLayer '定义球员图层
1 R$ K+ I1 r2 a5 CDim playerblock As AcadBlock '定义块变量
Dim arcc(0 To 2) As Double '圆弧圆心
% U, I! g6 l: \+ oDim linep1(0 To 2) As Double '线条端点1
6 Y# u$ ?+ Q# r  `Dim linep2(0 To 2) As Double '线条端点2
Dim pline(0 To 20) As Double '定义队服右侧多段线7个顶点
. Q+ P; n  z& v9 \Dim basep(0 To 2) As Double '块基点
Dim playernumberpoint(0 To 2) As Double '块属性插入点
! K  ]% V2 \% [* K$ e/ r9 qDim mytxt As AcadTextStyle '定义mytxt变量为文本样式
Dim blockRef As AcadBlockReference '定义块属性变量
" j# L( s4 t9 H5 QDim Attr3 As Variant '插入块属性变量

$ Z( {7 W$ Z6 J" m/ @  d- y% n/ @Set playerblock = ThisDrawing.Blocks.Add(basep, "球员") '定义一个"球员"的块

; _8 E, {  C% t# c+ N0 J) carcc(0) = 0
% ?: w% T3 S2 Uarcc(1) = 430
Call playerblock.AddArc(arcc, 50, ThisDrawing.Utility.AngleToReal(180, 0), 0) '画弧并加入块中
* R/ O4 t/ [1 k2 X
  }$ O& Z! {  V9 W2 Y* Gpline(0) = 0
pline(1) = 20
2 X- w  Q; \& p" A) E
& {) A4 Y" M% G6 E* b) p" P& _+ kpline(3) = 100
4 o  k7 t. P2 X6 E' opline(4) = 20
; `( @# B3 u: \
pline(6) = 100
pline(7) = 250
4 v) P& Z. h' J: \, b% [9 y
. J) ~5 `8 G6 o9 b, r0 Hpline(9) = 125
pline(10) = 207
2 C$ g& U# S, Z3 H
pline(12) = 212
pline(13) = 257
4 R: }6 p* G/ w! j$ o

" x, K: h. N9 Rpline(15) = 112
pline(16) = 430


pline(18) = 50
/ @% Y  i/ ~7 k3 qpline(19) = 430
/ m; D- M- n2 D! C
; d% M$ ], _# F" H1 tSet line1 = ThisDrawing.ModelSpace.AddPolyline(pline) '画队服右侧多段线

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

Dim p(0 To 2) As Double '定义坐标变量
Set mytxt = ThisDrawing.TextStyles.Add("mytxt") '添加mytxt样式
& L7 h2 T$ \1 @" z/ m; H' T, q) }mytxt.fontFile = "c:\windows\fonts\simfang.ttf" '设置字体文件为仿宋体
ThisDrawing.ActiveTextStyle = mytxt '将当前文字样式设置为mytxt
& b! `# u, m3 n" V; N" L
9 G  ?- d& q# \+ r* C9 _playernumberpoint(0) = 0 '块属性位置
1 r& a) e* w8 H& b8 K$ a2 i( S# jplayernumberpoint(1) = 200
! `5 u! m# h) g; u7 s' ]) YSet attr1 = ThisDrawing.ModelSpace.AddAttribute(100, acAttributeModeNormal, "号码", playernumberpoint, "X", 0) '画块属性
attr1.Alignment = 7 '居中
* o/ W0 A$ E# f) @! Eattr1.TextAlignmentPoint = playernumberpoint '重定义对齐点
9 n8 I. c$ `! SSet attr2 = ThisDrawing.ModelSpace.AddAttribute(100, acAttributeModeNormal, "姓名", playernumberpoint, "???", 0) '画块属性
attr2.Alignment = 7 '居中

" E) i. O& [$ @. a  U
4 N( d, A4 d5 A) ^Dim objCollection(0 To 3) As Object '创建选择集
8 g% V) \1 q) N  q: D  zSet objCollection(0) = line1 '线条1加入选择集
Set objCollection(1) = line2 '线条2加入选择集
Set objCollection(2) = attr1 '属性1加入选择集
Set objCollection(3) = attr2 '属性2加入选择集

" B$ @8 P% @% W% J2 f. lCall ThisDrawing.CopyObjects(objCollection, playerblock) '把选择集加入块中
0 x; C6 M; w0 ^1 C0 i; \
For Each element In objCollection '在选择集中进行循环
: F  l8 e% @7 A, g$ i  element.Delete '删除线条和属性(此操作并不影响已创建的块)
3 c( q8 u0 l+ V- MNext


Set playerlay = ThisDrawing.Layers.Add("球员") '新建图层
# ]! y/ t: K0 N( P% `% O9 uplayerlay.color = 2 '为黄色
ThisDrawing.ActiveLayer = playerlay '将当前图层设置为球员图层
. p; o* ^9 o& N0 x5 |3 I0 `
$ d, C6 \; O" S8 D, O! K1 s1 L' lDim p1 As Variant '块插入点位置
" b2 A; [. S, H. X
For i = 1 To 11 '插入块
# a* G8 s( |, ]. s8 O$ ^  pstring = CStr(i) & "号球员位置："
3 v6 E* A9 J, Y  p1 = ThisDrawing.Utility.GetPoint(, pstring) '点选球员位置坐标
* `& P1 V6 X  _  nstring = ThisDrawing.Utility.GetString(30, "球员姓名：")
0 x; z7 x7 K; I( t, U3 E  Set blockRef = ThisDrawing.ModelSpace.InsertBlock(p1, "球员", 1, 1, 1, 0) '插入块
" o" u9 h0 P  ?  d7 O, W  Attr3 = blockRef.GetAttributes '获取块属性
  Attr3(0).TextString = CStr(i) '赋值球员号码
* H8 ]3 F* Q9 W. b: Z  Attr3(1).TextString = nstring '赋值球员姓名
Next
$ _" W3 C; E+ _( q
End Sub

+ ~7 q% f) Z2 `0 ]: p本课思考题：
1 ~/ W. V2 R( R5 f1、在本课例程的最后一段增加出错陷阱代码，当用户输入非正常数值时退出程序
2 j2 L. B- a) p) i' `2 R  r2、画一个简易路灯块，用属性块做为路灯编号，由用户点选路灯位置，程序画路灯时自动为路灯编号

trinco

很有帮助！谢谢lz

cgc

终于看好了，写得很不错， 连我从来不写程序的人都能看得懂了

好好学习，感觉函数 方面还有很多的东西不是很懂
% G! X4 p; X; L4 M" W3 p
2 h, R8 o' M/ v有函数库可以查阅么？
2 E7 ~8 ]7 U  v* L& U
2 L3 A3 B3 X1 D. E* I2 F买书也行

nebs

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

lianghn1986

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

pianpi111

auto cad vba第一次听说
学学

nebs

顶！！ 学习中.....

sod11791

太难了，能学会吗？

kyokula

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