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

jshailin

Sub falan()
Dim centerp As Variant '中心坐标
  U; f0 y+ ?$ U) Y( b- NDim templay As AcadLayer '定义临时层
4 W: w6 _0 j, V/ w4 pDim lay0 As AcadLayer '定义粗实线层
Dim lay1 As AcadLayer '定义中心线层
Dim oldlay As AcadLayer '定义原来的层
- M# D" [8 U5 CDim ent As AcadCircle '定义对象
On Error Resume Next
( c+ Q3 h/ _! |( R1 O. [wj = ThisDrawing.Utility.GetReal("外径(0～10000)<520>") '输入外径尺寸
If Err.Number <> 0 Then '用户输入的不是有效的数字
  u$ l  ?6 X6 q! I% y1 t/ j   wj = 520
   Err.Clear '清除错误
End If
nj = ThisDrawing.Utility.GetReal("内径(0～10000)<380>") '输入内径尺寸
( r! `& R" z, N9 Z3 V. Y2 s6 n. g7 }If Err.Number <> 0 Then '用户输入的不是有效的数字
$ `6 `- n1 a& l   nj = 380
   Err.Clear '清除错误
End If
* h* b( y; @' S3 Rzxj = ThisDrawing.Utility.GetReal("周围孔中心直径(0～10000)<480>") '输入周围孔中心直径尺寸
If Err.Number <> 0 Then '用户输入的不是有效的数字
* m1 }; @* p4 n0 J  ]2 U6 k   zxj = 480
   Err.Clear '清除错误
End If
+ I1 T/ E" y. F3 n. v% p! K* c1 Ukj = ThisDrawing.Utility.GetReal("周围孔径(0～100)<24>") '输入周围孔径尺寸
If Err.Number <> 0 Then '用户输入的不是有效的数字
   kj = 24
" c1 l5 i1 o+ Z% E   Err.Clear '清除错误
End If
kgs = ThisDrawing.Utility.GetInteger("周围孔个数(0～100)<12>") '输入周围孔个数
$ n0 h0 A# t" B- iIf Err.Number <> 0 Then '用户输入的不是有效的数字
   kgs = 12
9 [' @2 r. ~& M& L; c- T; w   Err.Clear '清除错误
End If
0 V) r+ B! w( `7 @  Lkgs = kgs + 1
centerp = ThisDrawing.Utility.GetPoint(, "定位法兰中心：") '设定中心坐标
) e3 y4 D' s* b1 @" ?; ~+ [Set oldlay = ThisDrawing.ActiveLayer '记住当前图层
For Each templay In ThisDrawing.Layers '查找图层名为1的图层
    If templay.Name = "1" Then
0 \- q& I/ ^5 K( b/ e0 ~5 y& H        Set lay0 = templay '找出图层名为1的为粗线层
% |: E4 K& G4 c2 z    End If
6 u: |- D2 ^. {& g+ L7 t/ i: d$ W& K    If templay.Name = "0" Then
        Set lay1 = templay '找出图层名为0的为中心线层
    End If
; f) ]; C2 ~1 A! hNext templay
   
ThisDrawing.ActiveLayer = lay0 '把当前图层设为粗线层
Call ThisDrawing.ModelSpace.AddCircle(centerp, wj / 2) '画外圆圈
Call ThisDrawing.ModelSpace.AddCircle(centerp, nj / 2) '画内圆圈
( h1 n. h& h' p, Y& S& `1 s) T" QSet ent = ThisDrawing.ModelSpace.AddCircle(centerp, kj / 2) '画一个小孔
8 ~6 M3 g) x& K: ]Dim centerm(0 To 2) As Double '移动坐标
centerm(0) = centerp(0): centerm(1) = centerp(1) + zxj / 2: centerm(2) = centerp(2)

) `, W9 A9 A( dDim rent As Variant
ent.Move centerp, centerm
; [0 K* K) G! D6 H3 l* C* {' ?'rent = ent.ArrayPolar(kgs, 2 * pi, centerp)
  }: t5 B* q7 I6 @ent.ArrayPolar kgs, 2 * 3.1415926, centerp
, [' s& {! Z7 V$ V  Z- ^5 r+ q
' t+ J2 y6 B7 f$ p0 ^ThisDrawing.ActiveLayer = lay1 '把当前图层设为中心线层
+ C4 |" @7 p% C# SCall ThisDrawing.ModelSpace.AddCircle(centerp, zxj / 2) '画外圆圈
Dim clpoint1(0 To 2) As Double '坐标
$ x$ V) N$ Y' n& ]Dim clpoint2(0 To 2) As Double '坐标
2 |* l- z* H/ F, }; B! W6 L6 E3 Mclpoint1(0) = centerp(0) - 10 - wj / 2: clpoint1(1) = centerp(1): clpoint1(2) = centerp(2)
! @) T0 h( w% B9 h0 Wclpoint2(0) = centerp(0) + 10 + wj / 2: clpoint2(1) = centerp(1): clpoint2(2) = centerp(2)
3 l1 a" d% [* e/ \Call ThisDrawing.ModelSpace.AddLine(clpoint1, clpoint2)
clpoint1(0) = centerp(0): clpoint1(1) = centerp(1) - 10 - wj / 2: clpoint1(2) = centerp(2)
# o7 _0 e- V9 R1 Z: @- s6 e. uclpoint2(0) = centerp(0): clpoint2(1) = centerp(1) + 10 + wj / 2: clpoint2(2) = centerp(2)
$ y7 l4 @1 Q; D: H9 ZCall ThisDrawing.ModelSpace.AddLine(clpoint1, clpoint2)
clpoint1(0) = centerp(0): clpoint1(1) = ent.Center(1) - 10 - kj / 2: clpoint1(2) = centerp(2)
clpoint2(0) = centerp(0): clpoint2(1) = ent.Center(1) + 10 + kj / 2: clpoint2(2) = centerp(2)
1 h7 p4 C( l0 x5 t7 EDim lent As AcadLine
9 r: h; I. h* s, i6 C+ I$ ^* \& iSet lent = ThisDrawing.ModelSpace.AddLine(clpoint1, clpoint2)
# [2 m- b5 R- B; [& S0 o% rlent.ArrayPolar kgs, 2 * 3.1415926, centerp
( ]. d$ G! C  }# r3 Y+ u- w' Vlent.Delete
) z8 U; W, J* i. y2 |' a& b& sent.Delete
0 \$ h' {( b2 m7 n& n9 `* }ThisDrawing.ActiveLayer = oldlay '把当前图层还原
7 w1 a8 }( y0 Y: ?4 PZoomExtents '显示整个图形
End Sub

jshailin

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

woaishuijia

这个程序如果自用，已经完全可以了。如果共享则还有些不太合理的地方：
+ E) f5 ]% t7 h. c1、
wj = ThisDrawing.Utility.GetReal("外径(0～10000)<520>") '输入外径尺寸
If Err.Number <> 0 Then '用户输入的不是有效的数字
wj = 520
Err.Clear '清除错误
& J  R+ `) B/ y3 M2 I8 lEnd If
及后面类似获取数值的部分
  V$ N+ I9 Y& @; h% h如果用户输入的是负值怎么办？如果用户想按“Esc”退出命令怎么办？

$ t) a2 M5 i* K- S+ a( x, z4 k1 Y0 b3 [2、
+ y( L4 G% C. h3 _- t2 ~0 [centerp = ThisDrawing.Utility.GetPoint(, "定位法兰中心：") '设定中心坐标
如果用户没有输入点坐标而直接按回车、空格或按“Esc”怎么办？

& p* f$ \- d, g; B1 D; C) @还有一些小的瑕疵，比如：
Set ent = ThisDrawing.ModelSpace.AddCircle(centerp, kj / 2) '画一个小孔
Dim centerm(0 To 2) As Double '移动坐标
2 }8 ]3 D+ k) w) [centerm(0) = centerp(0): centerm(1) = centerp(1) + zxj / 2: centerm(2) = centerp(2)
* `4 I' y0 e% N; H9 S5 W; Ient.Move centerp, centerm
为什么不直接把小孔画在centerm呢？
# Q; k; b4 W% R, y" F, J- ?
( ?, {+ w- Q: J* L' E还有，建议你把VBA编辑器中“选项”对话框下“编辑器”选项卡的“要求变量声明”勾选上，以后不要用隐式声明变量，这可以避免低级错误。

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

nanisan

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

yurenai85

楼主好心人，我急用呢

antaixjh

厉害厉害！！！

antaixjh

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

tongji007

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

魔域罗兰

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

qjydz

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

raymondou

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

zhuguiping

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