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

jshailin

Sub falan()
Dim centerp As Variant '中心坐标
1 \; K% m) X5 u8 q( U1 dDim templay As AcadLayer '定义临时层
6 u9 M) u% N% y# b6 o/ m& y1 s- jDim lay0 As AcadLayer '定义粗实线层
Dim lay1 As AcadLayer '定义中心线层
Dim oldlay As AcadLayer '定义原来的层
Dim ent As AcadCircle '定义对象
& q- O) L7 k# ~/ a+ D4 ^On Error Resume Next
, x# A" I$ O: H# ^wj = ThisDrawing.Utility.GetReal("外径(0～10000)<520>") '输入外径尺寸
/ K( F; f! r  p" f6 VIf Err.Number <> 0 Then '用户输入的不是有效的数字
& m/ W9 E! e  V$ i. e& W1 @   wj = 520
3 K# \2 Q9 W. s. l2 j   Err.Clear '清除错误
0 g" ~/ R1 l/ C, ?9 IEnd If
  g- {9 u$ `9 ^5 h- Unj = ThisDrawing.Utility.GetReal("内径(0～10000)<380>") '输入内径尺寸
If Err.Number <> 0 Then '用户输入的不是有效的数字
5 o$ x4 ~  A* V( l7 _1 T   nj = 380
   Err.Clear '清除错误
End If
  g1 ^4 |- Y- m% @zxj = ThisDrawing.Utility.GetReal("周围孔中心直径(0～10000)<480>") '输入周围孔中心直径尺寸
' M" `1 p/ Q8 @/ K# C7 ~" S9 n& d+ q- OIf Err.Number <> 0 Then '用户输入的不是有效的数字
   zxj = 480
   Err.Clear '清除错误
& v3 H+ U" j( rEnd If
kj = ThisDrawing.Utility.GetReal("周围孔径(0～100)<24>") '输入周围孔径尺寸
' Y; U- O7 b+ W- v8 x9 N  SIf Err.Number <> 0 Then '用户输入的不是有效的数字
3 S2 b% F, f5 v; U   kj = 24
0 f" {0 u, _$ `% T& r( g   Err.Clear '清除错误
End If
/ ~/ ]0 b! h. I  {" w! ~0 C1 tkgs = ThisDrawing.Utility.GetInteger("周围孔个数(0～100)<12>") '输入周围孔个数
. @1 O) d! d  G4 F3 E! DIf Err.Number <> 0 Then '用户输入的不是有效的数字
   kgs = 12
& X, S6 m7 e6 u, ~  s3 T9 t   Err.Clear '清除错误
- N# Y4 v8 s" u. J0 |+ [End If
kgs = kgs + 1
. m$ I6 B- C6 @6 U; f1 e  a% ecenterp = ThisDrawing.Utility.GetPoint(, "定位法兰中心：") '设定中心坐标
Set oldlay = ThisDrawing.ActiveLayer '记住当前图层
For Each templay In ThisDrawing.Layers '查找图层名为1的图层
" |+ ?9 B8 Q, ^, w9 s    If templay.Name = "1" Then
        Set lay0 = templay '找出图层名为1的为粗线层
% U! c9 Y7 N" M8 o1 m    End If
" _% p5 N0 n! z( _- {    If templay.Name = "0" Then
: k: J' Z/ a; m. ~) s1 M' C        Set lay1 = templay '找出图层名为0的为中心线层
    End If
Next templay
0 u$ d! T# n2 n/ K9 A" u+ ?$ q   
ThisDrawing.ActiveLayer = lay0 '把当前图层设为粗线层
Call ThisDrawing.ModelSpace.AddCircle(centerp, wj / 2) '画外圆圈
Call ThisDrawing.ModelSpace.AddCircle(centerp, nj / 2) '画内圆圈
" h2 R2 w7 \6 RSet ent = ThisDrawing.ModelSpace.AddCircle(centerp, kj / 2) '画一个小孔
Dim centerm(0 To 2) As Double '移动坐标
3 g. y: E! U8 Ycenterm(0) = centerp(0): centerm(1) = centerp(1) + zxj / 2: centerm(2) = centerp(2)

Dim rent As Variant
" }/ P& r4 Y$ R) R% T% U5 ment.Move centerp, centerm
+ [( Y1 J6 Z' @'rent = ent.ArrayPolar(kgs, 2 * pi, centerp)
% ?3 z+ G: s, ?9 r2 vent.ArrayPolar kgs, 2 * 3.1415926, centerp

ThisDrawing.ActiveLayer = lay1 '把当前图层设为中心线层
* j: n% t. _( x5 J# u7 a, YCall ThisDrawing.ModelSpace.AddCircle(centerp, zxj / 2) '画外圆圈
Dim clpoint1(0 To 2) As Double '坐标
; N  h( y* ~# q/ O/ QDim clpoint2(0 To 2) As Double '坐标
+ Y; _: C' f1 e) T2 c6 _clpoint1(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)
Call ThisDrawing.ModelSpace.AddLine(clpoint1, clpoint2)
% \6 v  t$ _$ n$ G( j9 B/ V( eclpoint1(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)
! B* C- P- s! ~: s/ hCall ThisDrawing.ModelSpace.AddLine(clpoint1, clpoint2)
1 n7 ]; g& {. W- e% T2 Pclpoint1(0) = centerp(0): clpoint1(1) = ent.Center(1) - 10 - kj / 2: clpoint1(2) = centerp(2)
$ V# T8 f: ?# X4 E- d, _0 Hclpoint2(0) = centerp(0): clpoint2(1) = ent.Center(1) + 10 + kj / 2: clpoint2(2) = centerp(2)
Dim lent As AcadLine
! S7 ]" o, h' H# V; wSet lent = ThisDrawing.ModelSpace.AddLine(clpoint1, clpoint2)
% x. C" Q1 B( o. i, j9 S. {: P6 `lent.ArrayPolar kgs, 2 * 3.1415926, centerp
: e5 Y. y" G3 o# |  elent.Delete
ent.Delete
2 k0 q4 H2 a, N1 bThisDrawing.ActiveLayer = oldlay '把当前图层还原
ZoomExtents '显示整个图形
, f! L( S. Q7 R6 G2 e$ hEnd Sub

jshailin

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

woaishuijia

这个程序如果自用，已经完全可以了。如果共享则还有些不太合理的地方：
1、
wj = ThisDrawing.Utility.GetReal("外径(0～10000)<520>") '输入外径尺寸
If Err.Number <> 0 Then '用户输入的不是有效的数字
' N. F; h8 x' ^" x+ d( ~6 T( ^& Pwj = 520
& n3 }: B( A! ^: Q3 v) C) _Err.Clear '清除错误
End If
! A" c) y1 Z* A4 `# y5 d7 U3 Z及后面类似获取数值的部分
如果用户输入的是负值怎么办？如果用户想按“Esc”退出命令怎么办？

$ m( H4 `* ?  ?. s* I$ `: M: s2、
& L; [- p1 Y' x. i  Acenterp = ThisDrawing.Utility.GetPoint(, "定位法兰中心：") '设定中心坐标
如果用户没有输入点坐标而直接按回车、空格或按“Esc”怎么办？

) e) R  k" b6 n/ Q% t: j还有一些小的瑕疵，比如：
! h7 ?2 Q" k9 B$ L7 L3 {/ N# nSet ent = ThisDrawing.ModelSpace.AddCircle(centerp, kj / 2) '画一个小孔
& n! h6 K0 }, I& ~7 ]* L; WDim centerm(0 To 2) As Double '移动坐标
centerm(0) = centerp(0): centerm(1) = centerp(1) + zxj / 2: centerm(2) = centerp(2)
" m; Q$ k5 a( ~7 i  n, Eent.Move centerp, centerm
为什么不直接把小孔画在centerm呢？

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

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

nanisan

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

yurenai85

楼主好心人，我急用呢

antaixjh

厉害厉害！！！

antaixjh

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

tongji007

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

魔域罗兰

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

qjydz

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

raymondou

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

zhuguiping

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