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

jshailin

Sub falan()
Dim centerp As Variant '中心坐标
1 n- n5 E: E/ Y9 Q) EDim templay As AcadLayer '定义临时层
# m* |5 w+ g4 A  M8 Z# nDim lay0 As AcadLayer '定义粗实线层
$ N. C6 I7 j6 ?! U" b# w2 Y& LDim lay1 As AcadLayer '定义中心线层
! B9 K& I/ l$ x. KDim oldlay As AcadLayer '定义原来的层
Dim ent As AcadCircle '定义对象
On Error Resume Next
wj = ThisDrawing.Utility.GetReal("外径(0～10000)<520>") '输入外径尺寸
; B8 R: S% Q+ x8 gIf Err.Number <> 0 Then '用户输入的不是有效的数字
$ |+ S+ |- r7 t$ N" h5 p" f   wj = 520
   Err.Clear '清除错误
" A) Q- S/ A* pEnd If
nj = ThisDrawing.Utility.GetReal("内径(0～10000)<380>") '输入内径尺寸
3 O6 G) _4 U8 p. S) r9 @If Err.Number <> 0 Then '用户输入的不是有效的数字
0 B" Q, `; G9 }! j0 K8 V   nj = 380
) c5 ^8 [: r- s! }! T6 ]   Err.Clear '清除错误
End If
zxj = ThisDrawing.Utility.GetReal("周围孔中心直径(0～10000)<480>") '输入周围孔中心直径尺寸
6 T  ?( R- r9 ^If Err.Number <> 0 Then '用户输入的不是有效的数字
) N* U; m( Q* ~" {   zxj = 480
   Err.Clear '清除错误
1 D, f7 I1 E0 v5 B. |& PEnd If
# v1 F' f9 U, A! `0 k) t1 Vkj = ThisDrawing.Utility.GetReal("周围孔径(0～100)<24>") '输入周围孔径尺寸
7 U, |7 p' R9 W" h  ]4 GIf Err.Number <> 0 Then '用户输入的不是有效的数字
' \0 b4 o" e% P5 F- ]7 ]   kj = 24
   Err.Clear '清除错误
0 I9 g# k% \8 w1 b+ k+ U+ K. {+ YEnd If
kgs = ThisDrawing.Utility.GetInteger("周围孔个数(0～100)<12>") '输入周围孔个数
/ ~0 S% }4 ^! L) ]If Err.Number <> 0 Then '用户输入的不是有效的数字
   kgs = 12
   Err.Clear '清除错误
End If
kgs = kgs + 1
centerp = ThisDrawing.Utility.GetPoint(, "定位法兰中心：") '设定中心坐标
& D9 H6 Z# d4 U, y: r) ^4 @2 l( m: Y  kSet oldlay = ThisDrawing.ActiveLayer '记住当前图层
For Each templay In ThisDrawing.Layers '查找图层名为1的图层
    If templay.Name = "1" Then
        Set lay0 = templay '找出图层名为1的为粗线层
7 q6 z$ q0 v; f: h- n5 D: J    End If
  ^& ^0 o# S- N0 U. t, ?) O    If templay.Name = "0" Then
) U; b2 K; g, g        Set lay1 = templay '找出图层名为0的为中心线层
6 w" I4 _) t4 |' s2 T' }3 S- Q    End If
Next templay
   
ThisDrawing.ActiveLayer = lay0 '把当前图层设为粗线层
% t) j) l: q2 L% Q+ P0 x, t& P+ P- hCall ThisDrawing.ModelSpace.AddCircle(centerp, wj / 2) '画外圆圈
% l- V& a+ m. ACall ThisDrawing.ModelSpace.AddCircle(centerp, nj / 2) '画内圆圈
' K4 ^" H" l7 J. J2 fSet ent = ThisDrawing.ModelSpace.AddCircle(centerp, kj / 2) '画一个小孔
Dim centerm(0 To 2) As Double '移动坐标
" \) q0 t2 M$ ~centerm(0) = centerp(0): centerm(1) = centerp(1) + zxj / 2: centerm(2) = centerp(2)

2 f/ e3 A, N/ s3 b6 ]' ^Dim rent As Variant
4 w! \3 p3 {: z- r% s% zent.Move centerp, centerm
'rent = ent.ArrayPolar(kgs, 2 * pi, centerp)
) g' L: x5 L$ w: [: _ent.ArrayPolar kgs, 2 * 3.1415926, centerp
* t$ u  I) w: Q: P2 D/ ?" d+ Y
# f# d9 x0 S+ F7 q$ Y3 M& tThisDrawing.ActiveLayer = lay1 '把当前图层设为中心线层
& S# D" A3 |1 b3 ]# ?2 j& CCall ThisDrawing.ModelSpace.AddCircle(centerp, zxj / 2) '画外圆圈
+ m( l$ x1 A. _! B$ qDim clpoint1(0 To 2) As Double '坐标
7 e+ ?. F, t4 F; ?Dim clpoint2(0 To 2) As Double '坐标
2 f8 J1 Z" K% tclpoint1(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)
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)
) k3 h- ]1 e: O& B' _& ECall ThisDrawing.ModelSpace.AddLine(clpoint1, clpoint2)
6 l" i0 A" E# O& V0 oclpoint1(0) = centerp(0): clpoint1(1) = ent.Center(1) - 10 - kj / 2: clpoint1(2) = centerp(2)
: h9 G1 j9 m1 U9 r: Cclpoint2(0) = centerp(0): clpoint2(1) = ent.Center(1) + 10 + kj / 2: clpoint2(2) = centerp(2)
Dim lent As AcadLine
. ]  L# n7 H' J5 O& u7 J  m/ hSet lent = ThisDrawing.ModelSpace.AddLine(clpoint1, clpoint2)
4 ^( A& F; F  c) d- v; {lent.ArrayPolar kgs, 2 * 3.1415926, centerp
1 }8 A0 O2 W0 P; o' |lent.Delete
ent.Delete
ThisDrawing.ActiveLayer = oldlay '把当前图层还原
ZoomExtents '显示整个图形
, Q. R: ~% j0 HEnd Sub

jshailin

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

woaishuijia

这个程序如果自用，已经完全可以了。如果共享则还有些不太合理的地方：
1、
& z0 ]' h/ l8 k7 Hwj = ThisDrawing.Utility.GetReal("外径(0～10000)<520>") '输入外径尺寸
' S7 a' s5 H9 @* MIf Err.Number <> 0 Then '用户输入的不是有效的数字
5 M9 `7 S4 P$ q  w9 Fwj = 520
Err.Clear '清除错误
End If
) e) r6 Z. t1 ]" E1 h. ]及后面类似获取数值的部分
$ O5 `! c0 M: W8 u如果用户输入的是负值怎么办？如果用户想按“Esc”退出命令怎么办？
5 A: J' y( m7 z
0 _! g" \- Y0 x3 l" n& h* q" y4 \2、
3 B3 ?. V) ^+ U2 H+ Z% L: b* bcenterp = ThisDrawing.Utility.GetPoint(, "定位法兰中心：") '设定中心坐标
% x( }  |& y* K8 a/ A如果用户没有输入点坐标而直接按回车、空格或按“Esc”怎么办？
% W' E. }7 v, c6 K; O
还有一些小的瑕疵，比如：
" w9 r! W% n# K+ ^: _7 s) o1 J! i, h  SSet ent = ThisDrawing.ModelSpace.AddCircle(centerp, kj / 2) '画一个小孔
- J+ E& g( k$ D  P. c( ~) oDim centerm(0 To 2) As Double '移动坐标
( ?1 `9 d+ w+ tcenterm(0) = centerp(0): centerm(1) = centerp(1) + zxj / 2: centerm(2) = centerp(2)
% L+ \0 B, T) A& y: @ent.Move centerp, centerm
为什么不直接把小孔画在centerm呢？

2 }$ K+ [+ T4 w" a5 i9 h: S' k4 Z1 q还有，建议你把VBA编辑器中“选项”对话框下“编辑器”选项卡的“要求变量声明”勾选上，以后不要用隐式声明变量，这可以避免低级错误。
0 j0 m% q5 L8 v7 d( D  H
友情提示：“GetReal”、“GetInteger”和“GetPoint”方法按下空格或回车的错误代码是-2145320928

nanisan

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

yurenai85

楼主好心人，我急用呢

antaixjh

厉害厉害！！！

antaixjh

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

tongji007

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

魔域罗兰

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

qjydz

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

raymondou

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

zhuguiping

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