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

pengyg1204

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

wangpiwujing

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

yhfsmu

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

设计从零

支持楼主！！！
  ~& A( b' S! {$ T5 a& M0 W！

hellmen

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

tianyunxuan

简单地讲，参数化设计就是根据参数进行精确绘图，绘图所需要的参数也可以由用户手工输入。真正的参数化设计往往需要数据库操作，为了简化程序，把数据库部分放在以后的课程中详细讲解。
5 r+ ]+ {8 f/ N3 y) Z$ v
    本课的例程是画一个标准足球场。足球场长度90～120米，宽度45～90米，而红色标注的尺寸是程序默认的，绿色标注固定不变。

' o! o! a) G$ K7 \% d' ~8 T

' l' t( d5 P3 _6 Z
# ~  i  f2 G5 t, GSub court()
Dim courtlay As AcadLayer '定义球场图层
Dim ent As AcadEntity '镜像对象
+ A  j1 ]0 W6 L  O2 rDim linep1(0 To 2) As Double '线条端点1
( M- h  z: g7 ^; i& D3 r) uDim linep2(0 To 2) As Double '线条端点2
Dim linep3(0 To 2) As Double '罚球弧端点1
( A% g, n+ M  GDim linep4(0 To 2) As Double '罚球弧端点2
Dim centerp As Variant '中心坐标
. j* r+ @7 p" x0 y% fxjq = 11000 '小禁区尺寸
" ?% u7 @; v6 r0 F& u" [djq = 33000 '大禁区尺寸
fqd = 11000 '罚球点位置
1 t1 L4 y( B+ D) u) {9 o% Ffqr = 9150 '罚球弧半径
fqh = 14634.98 '罚球弧弦长
, {: @5 Q( j$ \2 N4 jjqqr = 1000 '角球区半径
zqr = 9150 '中圈半径

# y. C, e! K7 f7 t0 C& ~On Error Resume Next
chang = ThisDrawing.Utility.GetReal("长度(90000～120000)<105000>")
If Err.Number <> 0 Then '用户输入的不是有效数字
" D2 K1 j# L2 e* `) Z  chang = 105000
  Err.Clear '清除错误
! o. L  g/ |8 m& a% ?0 uEnd If
5 K  g' A/ }& ~* g, ?: ?  F$ q$ K2 Zkuan = ThisDrawing.Utility.GetReal("宽度(45000～90000)<68000>")
! C# |5 f9 }  P! j6 J" T+ s; ~If Err.Number <> 0 Then
0 i0 c3 e8 I# H0 {$ a  kuan = 68000
" e* x5 Z4 O0 lEnd If
5 D' s! V3 Z; u2 ^
, a7 e9 R9 e$ E2 A! S! J5 Ecenterp = ThisDrawing.Utility.GetPoint(, "定位球场中心:")

Set courtlay = ThisDrawing.Layers.Add("足球场") '设置图层
6 x% t& q! y4 r" k: W( ^ThisDrawing.ActiveLayer = courtlay '把当前图层设为足球场图层
9 ~8 @/ r$ ?& e
) J) b$ S! }6 W& H# t& f. K'画小禁区
- C, A2 h3 V4 X4 s. f- k, l- X0 T: Ulinep1(0) = centerp(0) + chang / 2
9 @9 v& X# O+ y$ I! Z* a( }, }linep1(1) = centerp(1) + xjq / 2
linep2(0) = centerp(0) + chang / 2 - xjq / 2
linep2(1) = centerp(1) - xjq / 2
) E& m3 A* Y* z* f' sCall drawbox(linep1, linep2) '调用画矩形子程序
  v; [# M  i+ `$ O' _
0 q- n! F+ p4 b, R

'画大禁区
linep1(0) = centerp(0) + chang / 2
linep1(1) = centerp(1) + djq / 2
  ^) s3 X' J7 r  Rlinep2(0) = centerp(0) + chang / 2 - djq / 2
linep2(1) = centerp(1) - djq / 2
3 ~8 m7 U5 f6 T: y: I  BCall drawbox(linep1, linep2)

8 w. w2 i# {" q7 E7 l
) F8 H' x2 c6 S: ~! X' 画罚球点
; `0 m3 P3 N9 G4 Z5 j. f) R2 R/ Qlinep1(0) = centerp(0) + chang / 2 - fqd
linep1(1) = centerp(1)
Call ThisDrawing.ModelSpace.AddPoint(linep1)
7 q; m( _* g. ?" L. G* i'ThisDrawing.SetVariable "PDMODE", 32 '点样式
! |0 N  m5 p6 w, p) f# HThisDrawing.SetVariable "PDSIZE", 30 '点的尺寸

+ [, n8 G+ C* d* R8 X/ v'画罚球弧，罚球弧圆心就是罚球点linep1
3 O& F  w4 U* n& c1 m  ^linep3(0) = centerp(0) + chang / 2 - djq / 2
linep3(1) = centerp(1) + fqh / 2
2 f4 Z1 H; @5 g! S8 \4 clinep4(0) = linep3(0) '两个端点的x轴相同
linep4(1) = centerp(1) - fqh / 2
' X' E" Q3 h! W5 V0 Wang1 = ThisDrawing.Utility.AngleFromXAxis(linep1, linep3) '计算角度
ang2 = ThisDrawing.Utility.AngleFromXAxis(linep1, linep4)
Call ThisDrawing.ModelSpace.AddArc(linep1, zqr, ang1, ang2) '画弧
. F! O' _: j$ n4 B1 V) ^: t0 P8 r
; U" G- P; A# m
'角球弧
ang1 = ThisDrawing.Utility.AngleToReal(90, 0) '角度转换为弧度
6 s- i. K9 t: u& A$ N9 Lang2 = ThisDrawing.Utility.AngleToReal(180, 0)
2 U4 A5 ~6 u( s5 H/ |/ vlinep1(0) = centerp(0) + chang / 2 '角球弧圆心
# S" {. N2 X4 \linep1(1) = centerp(1) - kuan / 2
9 U2 |+ `" r/ U$ e3 r0 H& w7 t% z& TCall ThisDrawing.ModelSpace.AddArc(linep1, jqqr, ang1, ang2) '画弧

" \% J# u% L3 p: X: ^ang1 = ThisDrawing.Utility.AngleToReal(270, 0)
linep1(1) = centerp(1) + kuan / 2
Call ThisDrawing.ModelSpace.AddArc(linep1, jqqr, ang2, ang1)

8 v3 \  \! z1 [1 H- i3 P4 n5 u
% |; N# s2 k; ^; \% Z- `
9 ^" ^* K, {/ [6 P3 J# c$ J'镜像轴
6 s  K, r+ D- m: t$ Hlinep1(0) = centerp(0)
linep1(1) = centerp(1) - kuan / 2
" A2 U+ M+ @. t  G2 z3 [linep2(0) = centerp(0)
9 n& ]: C, Q: ~4 B6 {# q0 Jlinep2(1) = centerp(1) + kuan / 2

# Q  G* @( J. S# [. c, W'镜像
0 X" a# o3 A/ B2 T1 KFor Each ent In ThisDrawing.ModelSpace '所有模型空间的对象进行一次循环
5 m' ?, n2 e1 X. B% O( R  If ent.Layer = "足球场" Then '对象在"足球场"图层中
    ent.Mirror linep1, linep2 '镜像
+ y- G$ C! l1 h( E7 Z  End If
Next ent
, z+ Q! H7 l4 q( @% R5 C: o
( Q$ @# B+ m+ }3 @0 k0 A) H'画中线
0 t' [0 q! d' ~" X$ kCall ThisDrawing.ModelSpace.AddLine(linep1, linep2)

'画中圈
  b) P, s0 ~) A6 i) I- _Call ThisDrawing.ModelSpace.AddCircle(centerp, zqr)
+ Y% D2 i0 b! A3 e# e
) J% [$ K+ B  i8 N3 ^* n0 }'画外框
linep1(0) = centerp(0) - chang / 2
8 s* i" O, N3 i1 d4 I& \0 [linep1(1) = centerp(1) - kuan / 2
; @; S! E9 e% }! Nlinep2(0) = centerp(0) + chang / 2
' F1 f! [+ S) T! elinep2(1) = centerp(1) + kuan / 2
* @1 U, c+ F! SCall drawbox(linep1, linep2)

ZoomExtents '显示整个图形
  ^, U. T; r& D# {) k' r/ i
End Sub

" Q/ f, K5 }; L2 L1 o( D: PPrivate Sub drawbox(p1, p2) '根据对角线坐标画矩形的子程序
; t4 W; N- U* ODim boxp(0 To 14) As Double
0 O$ J6 v: _) i. g
/ t( g0 |6 @0 @- Z$ e' k7 `8 Gboxp(0) = p1(0)
1 q5 l3 o" [% k( S5 ]& j' \: sboxp(1) = p1(1)

  k( k! s% R3 B/ n- y; Sboxp(3) = p1(0)
boxp(4) = p2(1)

! E% U! `" r  r; @7 uboxp(6) = p2(0)
boxp(7) = p2(1)

boxp(9) = p2(0)
boxp(10) = p1(1)
: m# F  B) h2 w
boxp(12) = p1(0)
: h# N, y( W% \+ aboxp(13) = p1(1)

Call ThisDrawing.ModelSpace.AddPolyline(boxp)
. H  E0 f, r. @! G! |
End Sub




下面开始分析源码：
& k8 E3 u# |! V  g0 x- U
- k1 ]# h' ?7 M; Z! G9 BOn Error Resume Next
chang = ThisDrawing.Utility.GetReal("长度(90～120)<10500>")
If Err.Number <> 0 Then '用户输入的不是有效数字
chang = 10500
# Z2 z+ J2 ]/ q8 Z' k/ V' ~Err.Clear '清除错误
End If
, V" q. e- Z, B( Q& k
8 H/ Z5 l2 d7 E  d, N. L$ @    这段代码的作用是要求用户输入一个足球场长度的数字，由于getreal只能输入数字，如果输入其他字符程序就会报错，所以先要用去掉错误提示：On Error Resume Next，虽然错误不再提示，但是出错代码会err.number改变，有兴趣的读者可以用变量跟踪的方法看看这个代码的数值。您只要记住，如果这个数字不是0，那么就是有错了，这时就可以把长度定为默认值，然后用Err.Clear语句把错误代码清零。

( }" n5 A0 Z; W5 |4 t
    在画小禁区的最后一行这样写：Call drawbox(linep1, linep2)
" X( R9 y' P+ K( h$ k+ T0 Q$ {6 I
7 Z3 q1 E5 e! u5 A    Drawbox并不是vba提供的方法，它是一个带参数的子程序。由于画足球场要画好几次矩形，
而vba没有提供一个现成的画矩形方法，如果每次都用一长串代码画矩形是很麻烦的，所以需要把这些麻烦的代码写到一个子程序中，在需要时只有写一条调用语句就行了。这个子程序最后几行，从“Private Sub drawbox(p1, p2) ”开始，到end sub结束，p1,p2是参数，调用时也必须写两个参数：linep1、linep2。
8 n! F& y6 ~- X

ang1 = ThisDrawing.Utility.AngleFromXAxis(linep1, linep3) '计算角度
ang2 = ThisDrawing.Utility.AngleFromXAxis(linep1, linep4)
Call ThisDrawing.ModelSpace.AddArc(linep1, zqr, ang1, ang2) '画弧

+ V+ y8 k* J, ?/ J9 t! ^7 V: V    画圆用addarc方法，需要4个参数：圆心、半径、起始角度、结束角度。AngleFromXAxis用于计算角度，其参数需要两个点坐标

& Q  C) {3 s) w0 Q+ P下面看镜像操作：
For Each ent In ThisDrawing.ModelSpace '所有模型空间的对象进行一次循环
- a3 I0 C: h0 o4 _7 i  If ent.Layer = "足球场" Then '对象在"足球场"图层中
    ent.Mirror linep1, linep2 '镜像
  End If
Next ent

    本例只对“足球场”图层中的对象进行镜像，所以要对全部对象进行循环，判断对象的图层属性，只有位于“足球场”图层中的对象才作镜像。
- a/ @2 s4 C6 l1 P& a

9 O- C: ]. }( H; b. S4 X  f本课思考题：
4 X- Q5 \2 \( V
1、对本课的例程进行修改，当用户输入长、宽不在规定的范围时要求用户重新输入

2、设计一张简单的平面图，用户输入2个参数，其他尺寸写进程序中
" G, a- R' c2 t3 D# D; ^+ U
+ c4 I5 x8 g  T) i[ 本帖最后由 tianyunxuan 于 2007-5-26 20:10 编辑 ]

tianyunxuan

定义块方法：

) ^% \9 J5 e& h$ l+ w1 o2 j' lSet blocksobj=ThisDrawing.Blocks.Add(基点, 块名)
  }3 H4 Q7 T' }( _7 ?把选择集加入块中的方法：
, e) ^( k$ D$ iThisDrawing.CopyObjects(选择集,块)
插入块方法：
ThisDrawing.ModelSpace.InsertBlock(插入点,块名, X轴比例,Y轴比例,Z轴比例, 旋转角度)
9 @' S7 J* \! e% k# R画块属性方法：
ThisDrawing.ModelSpace.AddAttribute(文字高度,模式,提示字符, 插入点, 显示字符,默认值)
1 ?5 Q" P" U& }0 w一共有五种模式，在输入时会有提示，其中最常用的是“acAttributeModeNormal”普通模式
7 n# ]" M4 ]8 k5 ^6 X# B) @9 f: F$ h
8 s( Q# U% p. q$ T: v# C
7 O: P$ Y+ q  c: W# M下面的例题是利用属性块画足球场的阵型图。
程序画出一个球员块，然后把块写到用户指定位置，球员号码由程序自动递增，把球员姓名改为用户输入值。画足球场请参阅上一课内容。

+ ~5 J" L" A/ X
8 q% `" e0 z' j* k
( R" ?, C) N5 z4 G; p% f
' f3 a) p' v  [# w& x

编程思路：
1．定义一个空块
2．在块中画一段弧（球服衣领）
3．画多段线，镜像画出球衣
! U# j; P' }2 D7 q% U4．画块属性，由于块属性默认的对齐方式是左对齐，而球员号码应该居中，所以必须把块的对齐属性改为居中。但是当这个属性更改时块属性对齐点会自动归零，所以不得不再次更改对齐点属性
6 |* G7 f; _- O: f) }5．把多段线和属性复制到块中
1 k- p& E( P* L# T6 J3 [* s4 g, M+ |( l0 c' m6．提示用户点选球员位置和姓名
7．插入块，修改球衣号码属性、球员姓名属性
5 X# t, _2 G2 G$ z& S$ ^& P
以下是源码，附有详细的注释，如果有疑问，建议用变量跟踪法研究一下。
Sub team()
8 k+ q( l2 ]+ L. b# D- J- ?Dim playerlay As AcadLayer '定义球员图层
Dim playerblock As AcadBlock '定义块变量
Dim arcc(0 To 2) As Double '圆弧圆心
Dim linep1(0 To 2) As Double '线条端点1
; |6 ^7 n; X5 w! a$ I" @Dim linep2(0 To 2) As Double '线条端点2
Dim pline(0 To 20) As Double '定义队服右侧多段线7个顶点
Dim basep(0 To 2) As Double '块基点
4 ~! @+ X2 a9 m+ A0 c9 nDim playernumberpoint(0 To 2) As Double '块属性插入点
Dim mytxt As AcadTextStyle '定义mytxt变量为文本样式
% j* G2 \4 R) ~0 x6 g% ]+ fDim blockRef As AcadBlockReference '定义块属性变量
! J; m  O5 z. l, i" J: \/ ^* }$ LDim Attr3 As Variant '插入块属性变量
! Y) N6 `( i, i0 O1 v! ^% Q
6 ^7 H' [1 r# d1 s+ {/ w' @Set playerblock = ThisDrawing.Blocks.Add(basep, "球员") '定义一个"球员"的块
' e+ s1 ~6 T3 ]$ p
arcc(0) = 0
: O# c1 T- f  Q  m3 _9 E& jarcc(1) = 430
1 J9 g) D( ]2 O* WCall playerblock.AddArc(arcc, 50, ThisDrawing.Utility.AngleToReal(180, 0), 0) '画弧并加入块中

& a/ m. h2 L+ W) n' L4 m' n7 `pline(0) = 0
5 u: i3 G; E  ^2 }8 Z: mpline(1) = 20

pline(3) = 100
0 M( Q5 B0 g* ^0 @* Kpline(4) = 20

pline(6) = 100
7 o# X: A' }2 a! f/ npline(7) = 250

% g( U5 x% [- j# O# R/ f; S$ Wpline(9) = 125
4 s* `  L! p! ^' n. ?) B0 zpline(10) = 207
/ T, n1 \8 y9 {4 R: v* X4 Z, ~
pline(12) = 212
pline(13) = 257
5 }$ |/ p9 J. X0 @# k
/ D$ E$ u% d5 @: i; h8 M
pline(15) = 112
6 ~2 k3 j3 Y- W6 u( c+ ipline(16) = 430
% W) Z) z' ^8 ]+ E! ]
. F# |* D9 J. f
; V! S: O0 Y( ~, Apline(18) = 50
pline(19) = 430
- g! B& G$ g5 [  A# _
Set line1 = ThisDrawing.ModelSpace.AddPolyline(pline) '画队服右侧多段线

# d# G# S! A0 O6 O' O( ^) nlinep2(1) = 1 '镜像轴第二点位于Y轴上任一点
Set line2 = line1.Mirror(linep1, linep2) '镜像获得另一半多段线
% U0 S5 [" V3 Q5 s; w* @
  i' s1 w7 R) L! a  w( ^- gDim p(0 To 2) As Double '定义坐标变量
Set mytxt = ThisDrawing.TextStyles.Add("mytxt") '添加mytxt样式
; S' O; P- U$ t5 }mytxt.fontFile = "c:\windows\fonts\simfang.ttf" '设置字体文件为仿宋体
# l3 w" w+ l/ mThisDrawing.ActiveTextStyle = mytxt '将当前文字样式设置为mytxt
+ }3 [0 S, ^6 L- z
playernumberpoint(0) = 0 '块属性位置
playernumberpoint(1) = 200
; m. t* Z+ J& [5 lSet attr1 = ThisDrawing.ModelSpace.AddAttribute(100, acAttributeModeNormal, "号码", playernumberpoint, "X", 0) '画块属性
attr1.Alignment = 7 '居中
attr1.TextAlignmentPoint = playernumberpoint '重定义对齐点
0 @* y% b3 X) R  q& c3 T" ]Set attr2 = ThisDrawing.ModelSpace.AddAttribute(100, acAttributeModeNormal, "姓名", playernumberpoint, "???", 0) '画块属性
: S5 Z9 o& {* ]& M) x. B6 Uattr2.Alignment = 7 '居中
3 i5 n0 v5 r2 t( {: T, L) L; \

Dim objCollection(0 To 3) As Object '创建选择集
Set objCollection(0) = line1 '线条1加入选择集
Set objCollection(1) = line2 '线条2加入选择集
2 z. J* a* B4 v- oSet objCollection(2) = attr1 '属性1加入选择集
Set objCollection(3) = attr2 '属性2加入选择集

Call ThisDrawing.CopyObjects(objCollection, playerblock) '把选择集加入块中

For Each element In objCollection '在选择集中进行循环
$ u, i* Q8 w! ^  k7 }/ y" h' @& R  element.Delete '删除线条和属性(此操作并不影响已创建的块)
Next


Set playerlay = ThisDrawing.Layers.Add("球员") '新建图层
playerlay.color = 2 '为黄色
ThisDrawing.ActiveLayer = playerlay '将当前图层设置为球员图层

9 \3 ^$ M6 k2 mDim p1 As Variant '块插入点位置
6 h' {& F+ p- a3 {. t3 O, S
3 B" R- c- A, @# m5 lFor i = 1 To 11 '插入块
  pstring = CStr(i) & "号球员位置："
  p1 = ThisDrawing.Utility.GetPoint(, pstring) '点选球员位置坐标
  nstring = ThisDrawing.Utility.GetString(30, "球员姓名：")
  Set blockRef = ThisDrawing.ModelSpace.InsertBlock(p1, "球员", 1, 1, 1, 0) '插入块
# w3 w5 p$ z9 m3 f: F5 }( ?  Attr3 = blockRef.GetAttributes '获取块属性
- Y! ^2 N1 q4 C% I  Attr3(0).TextString = CStr(i) '赋值球员号码
% M) x3 A" {( |! R  Attr3(1).TextString = nstring '赋值球员姓名
6 {: y3 f# v! r0 t3 \, kNext

, |. Y1 j' u% l9 @7 X+ c1 w1 KEnd Sub

本课思考题：
4 E3 }1 m1 k" _1、在本课例程的最后一段增加出错陷阱代码，当用户输入非正常数值时退出程序
/ |, y$ a% w2 u4 A' v6 x  n  f$ G, A2、画一个简易路灯块，用属性块做为路灯编号，由用户点选路灯位置，程序画路灯时自动为路灯编号

trinco

很有帮助！谢谢lz

cgc

终于看好了，写得很不错， 连我从来不写程序的人都能看得懂了
- E& I' ^4 H! d4 L# h; z
( e# Q) _& S1 b/ w* Z" e好好学习，感觉函数 方面还有很多的东西不是很懂
! m# r: Q* h* u% ]6 e
有函数库可以查阅么？

买书也行

nebs

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

lianghn1986

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

pianpi111

auto cad vba第一次听说
0 D- T) {) Z/ a9 V8 t: E+ J( x学学

nebs

顶！！ 学习中.....

sod11791

太难了，能学会吗？

kyokula

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