自己做的法兰参数化程序（VBA）

jshailin

Sub falan()
Dim centerp As Variant '中心坐标
Dim templay As AcadLayer '定义临时层
Dim lay0 As AcadLayer '定义粗实线层
- @; P: p) o, A0 j! I# c! {7 `1 DDim lay1 As AcadLayer '定义中心线层
1 A9 q& ?$ s/ sDim oldlay As AcadLayer '定义原来的层
) a9 _3 r& a7 O. h+ P, uDim ent As AcadCircle '定义对象
On Error Resume Next
5 f% x& V% ]' y  Q" Q' F+ u" V$ R- Wwj = ThisDrawing.Utility.GetReal("外径(0～10000)<520>") '输入外径尺寸
$ J; I5 w  k6 RIf Err.Number <> 0 Then '用户输入的不是有效的数字
   wj = 520
2 P" `) o+ C: }' {( K/ n: R. V6 V   Err.Clear '清除错误
( b! F/ |' r& ]$ V" ^: `$ P' gEnd If
nj = ThisDrawing.Utility.GetReal("内径(0～10000)<380>") '输入内径尺寸
' N' K( Q/ Z$ x+ s' E7 W0 RIf Err.Number <> 0 Then '用户输入的不是有效的数字
   nj = 380
   Err.Clear '清除错误
End If
zxj = ThisDrawing.Utility.GetReal("周围孔中心直径(0～10000)<480>") '输入周围孔中心直径尺寸
) c9 n# d+ {( {  OIf Err.Number <> 0 Then '用户输入的不是有效的数字
   zxj = 480
   Err.Clear '清除错误
End If
kj = ThisDrawing.Utility.GetReal("周围孔径(0～100)<24>") '输入周围孔径尺寸
If Err.Number <> 0 Then '用户输入的不是有效的数字
1 W4 [, G8 C) G0 Z, W$ `# n* v   kj = 24
   Err.Clear '清除错误
& l) ?% K# e" R0 G$ K9 N$ o3 UEnd If
' O- M; f8 F" i+ g5 |kgs = ThisDrawing.Utility.GetInteger("周围孔个数(0～100)<12>") '输入周围孔个数
) C8 \  S: [9 F+ t: r0 G% F/ jIf Err.Number <> 0 Then '用户输入的不是有效的数字
   kgs = 12
1 J( Z$ x! f! |' k   Err.Clear '清除错误
End If
kgs = kgs + 1
centerp = ThisDrawing.Utility.GetPoint(, "定位法兰中心：") '设定中心坐标
Set oldlay = ThisDrawing.ActiveLayer '记住当前图层
For Each templay In ThisDrawing.Layers '查找图层名为1的图层
9 a& [. ~: m1 K    If templay.Name = "1" Then
( X: ?5 E, N, s. R. c  l3 u3 \3 |        Set lay0 = templay '找出图层名为1的为粗线层
( @: ?3 {& E+ y$ A7 I- D    End If
- Y8 n3 n; p4 w1 h    If templay.Name = "0" Then
$ K8 l6 q3 }2 `- V        Set lay1 = templay '找出图层名为0的为中心线层
    End If
1 t* |5 t1 E0 k6 A" [4 t1 F0 SNext templay
& j5 ?5 x3 A$ E5 G: X: C4 K: R1 t   
ThisDrawing.ActiveLayer = lay0 '把当前图层设为粗线层
Call ThisDrawing.ModelSpace.AddCircle(centerp, wj / 2) '画外圆圈
Call ThisDrawing.ModelSpace.AddCircle(centerp, nj / 2) '画内圆圈
Set ent = ThisDrawing.ModelSpace.AddCircle(centerp, kj / 2) '画一个小孔
5 I% F/ R! T+ tDim centerm(0 To 2) As Double '移动坐标
centerm(0) = centerp(0): centerm(1) = centerp(1) + zxj / 2: centerm(2) = centerp(2)

Dim rent As Variant
: O0 t, c+ |7 @' w( {. \2 nent.Move centerp, centerm
'rent = ent.ArrayPolar(kgs, 2 * pi, centerp)
ent.ArrayPolar kgs, 2 * 3.1415926, centerp
  T6 p* k2 v' _9 t; d/ d6 _
* J% X! Z' e: I, e7 a0 g9 [ThisDrawing.ActiveLayer = lay1 '把当前图层设为中心线层
9 Y, P0 I* S# T7 p& U0 RCall ThisDrawing.ModelSpace.AddCircle(centerp, zxj / 2) '画外圆圈
Dim clpoint1(0 To 2) As Double '坐标
Dim clpoint2(0 To 2) As Double '坐标
# Q) ?4 A% B5 r1 B2 V; H' A8 A. a! Eclpoint1(0) = centerp(0) - 10 - wj / 2: clpoint1(1) = centerp(1): clpoint1(2) = centerp(2)
clpoint2(0) = centerp(0) + 10 + wj / 2: clpoint2(1) = centerp(1): clpoint2(2) = centerp(2)
4 E  r) I# y1 f4 MCall ThisDrawing.ModelSpace.AddLine(clpoint1, clpoint2)
clpoint1(0) = centerp(0): clpoint1(1) = centerp(1) - 10 - wj / 2: clpoint1(2) = centerp(2)
clpoint2(0) = centerp(0): clpoint2(1) = centerp(1) + 10 + wj / 2: clpoint2(2) = centerp(2)
Call ThisDrawing.ModelSpace.AddLine(clpoint1, clpoint2)
! {6 \$ n7 F) T2 ^  Wclpoint1(0) = centerp(0): clpoint1(1) = ent.Center(1) - 10 - kj / 2: clpoint1(2) = centerp(2)
0 d" W* V0 b1 q" Iclpoint2(0) = centerp(0): clpoint2(1) = ent.Center(1) + 10 + kj / 2: clpoint2(2) = centerp(2)
Dim lent As AcadLine
Set lent = ThisDrawing.ModelSpace.AddLine(clpoint1, clpoint2)
lent.ArrayPolar kgs, 2 * 3.1415926, centerp
lent.Delete
- F  M7 U9 p! i/ f/ Zent.Delete
, O, Q0 W6 S4 S5 h5 y3 m3 x/ TThisDrawing.ActiveLayer = oldlay '把当前图层还原
" q  z. B$ i( c  q; |ZoomExtents '显示整个图形
End Sub

jshailin

没人顶，路过的，发表点看法啊，给初学者点信心

woaishuijia

这个程序如果自用，已经完全可以了。如果共享则还有些不太合理的地方：
  @5 R4 f0 ^( B  O1、
wj = ThisDrawing.Utility.GetReal("外径(0～10000)<520>") '输入外径尺寸
If Err.Number <> 0 Then '用户输入的不是有效的数字
# ^& e2 E7 L; p  ?$ O3 Z2 I# awj = 520
Err.Clear '清除错误
; l/ U* l3 p' f. s1 ~End If
# Y3 d; G' O( v及后面类似获取数值的部分
如果用户输入的是负值怎么办？如果用户想按“Esc”退出命令怎么办？
) r8 j+ t: u( ~* `" f0 Y6 C/ U. n
/ g: N7 p- T3 z( |8 a1 S2、
- J$ L: V* S) v$ g+ y% k7 ~centerp = ThisDrawing.Utility.GetPoint(, "定位法兰中心：") '设定中心坐标
! ?+ i2 N5 v8 b. U/ T如果用户没有输入点坐标而直接按回车、空格或按“Esc”怎么办？

还有一些小的瑕疵，比如：
Set ent = ThisDrawing.ModelSpace.AddCircle(centerp, kj / 2) '画一个小孔
" E) k9 u& ~! s5 b( [2 p: I8 _Dim centerm(0 To 2) As Double '移动坐标
centerm(0) = centerp(0): centerm(1) = centerp(1) + zxj / 2: centerm(2) = centerp(2)
1 z. Z3 Z8 V8 D* k4 J) hent.Move centerp, centerm
" A5 {/ |/ I, q为什么不直接把小孔画在centerm呢？

还有，建议你把VBA编辑器中“选项”对话框下“编辑器”选项卡的“要求变量声明”勾选上，以后不要用隐式声明变量，这可以避免低级错误。

友情提示：“GetReal”、“GetInteger”和“GetPoint”方法按下空格或回车的错误代码是-2145320928

nanisan

试验了一下，功能还可以，鼓励一下。

yurenai85

楼主好心人，我急用呢

antaixjh

厉害厉害！！！

antaixjh

看了楼主发的这个程序后，自己感触很深~！！

tongji007

好东西 谢谢楼主分享  正需要

魔域罗兰

很好，顶一下，还要改进一下就好了

qjydz

我觉得这种参数化的设计还是在三维里搞更方便快捷一些

raymondou

能否出个画法兰剖视图的VBA程序出来啊？

zhuguiping

楼主，这个怎么用啊。多谢指教，我把它复制到命令栏后还是不能用啊，能不能上个详细的安装步骤啊