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

jshailin

Sub falan()
5 L. ^! y; T- T/ |$ F- QDim centerp As Variant '中心坐标
Dim templay As AcadLayer '定义临时层
0 Z( n: v; \; r  E5 n3 KDim lay0 As AcadLayer '定义粗实线层
. O( O( E+ p9 WDim lay1 As AcadLayer '定义中心线层
Dim oldlay As AcadLayer '定义原来的层
Dim ent As AcadCircle '定义对象
On Error Resume Next
wj = ThisDrawing.Utility.GetReal("外径(0～10000)<520>") '输入外径尺寸
If Err.Number <> 0 Then '用户输入的不是有效的数字
; U$ |9 @5 X9 e: b  ?# d* @  S   wj = 520
, }1 q; N8 M  Y+ s0 v6 J$ v   Err.Clear '清除错误
End If
) v7 Z2 U2 k& z6 u7 F9 snj = ThisDrawing.Utility.GetReal("内径(0～10000)<380>") '输入内径尺寸
9 q. l* s( w! A( d/ B* BIf Err.Number <> 0 Then '用户输入的不是有效的数字
, e' Z! r; z4 l" U3 \5 U   nj = 380
   Err.Clear '清除错误
End If
zxj = ThisDrawing.Utility.GetReal("周围孔中心直径(0～10000)<480>") '输入周围孔中心直径尺寸
# Z& a) I5 P$ zIf Err.Number <> 0 Then '用户输入的不是有效的数字
8 R# C& V4 j- r; L   zxj = 480
( B8 t+ `' S% b7 z% r   Err.Clear '清除错误
9 B* O1 L# y; A7 z2 N& YEnd If
- @. K/ }3 ?5 V  X' Okj = ThisDrawing.Utility.GetReal("周围孔径(0～100)<24>") '输入周围孔径尺寸
If Err.Number <> 0 Then '用户输入的不是有效的数字
  {) `0 @' W2 c! L6 L6 Q   kj = 24
   Err.Clear '清除错误
2 X2 O; u( T9 y# \/ k* {! gEnd If
kgs = ThisDrawing.Utility.GetInteger("周围孔个数(0～100)<12>") '输入周围孔个数
If Err.Number <> 0 Then '用户输入的不是有效的数字
   kgs = 12
) y* e( M) A* R+ Z   Err.Clear '清除错误
% a. o% p& A, \* X8 j: ?End If
kgs = kgs + 1
9 }# E! r9 w$ ?  Kcenterp = ThisDrawing.Utility.GetPoint(, "定位法兰中心：") '设定中心坐标
. n: d2 l) d. s( s  gSet oldlay = ThisDrawing.ActiveLayer '记住当前图层
/ M3 L  X! g6 Y9 N* G. y- VFor Each templay In ThisDrawing.Layers '查找图层名为1的图层
    If templay.Name = "1" Then
$ ]; W4 d; J" ?, c% q9 h. n        Set lay0 = templay '找出图层名为1的为粗线层
    End If
    If templay.Name = "0" Then
        Set lay1 = templay '找出图层名为0的为中心线层
    End If
Next templay
+ ~: q! e; X4 n   
ThisDrawing.ActiveLayer = lay0 '把当前图层设为粗线层
1 W/ D0 O8 _* a/ WCall ThisDrawing.ModelSpace.AddCircle(centerp, wj / 2) '画外圆圈
Call ThisDrawing.ModelSpace.AddCircle(centerp, nj / 2) '画内圆圈
1 o- X0 F, J4 p& N2 T5 NSet ent = ThisDrawing.ModelSpace.AddCircle(centerp, kj / 2) '画一个小孔
Dim centerm(0 To 2) As Double '移动坐标
7 R9 w6 i0 M8 E7 {) J$ Q0 P" fcenterm(0) = centerp(0): centerm(1) = centerp(1) + zxj / 2: centerm(2) = centerp(2)
0 I& P0 q3 b% p% E4 X. `- ~
, Z) b1 a; Z; w$ gDim rent As Variant
0 p: B( n- j. {2 d! b) n# l' N2 hent.Move centerp, centerm
6 @8 u  d) T7 Y% A'rent = ent.ArrayPolar(kgs, 2 * pi, centerp)
3 x( Q2 @; D9 nent.ArrayPolar kgs, 2 * 3.1415926, centerp
: f. y0 t* Z9 i% v
ThisDrawing.ActiveLayer = lay1 '把当前图层设为中心线层
Call ThisDrawing.ModelSpace.AddCircle(centerp, zxj / 2) '画外圆圈
Dim clpoint1(0 To 2) As Double '坐标
% P6 D# C+ ?4 @  f/ g) C6 hDim clpoint2(0 To 2) As Double '坐标
clpoint1(0) = centerp(0) - 10 - wj / 2: clpoint1(1) = centerp(1): clpoint1(2) = centerp(2)
' [4 F/ i! u7 c; J5 V. @clpoint2(0) = centerp(0) + 10 + wj / 2: clpoint2(1) = centerp(1): clpoint2(2) = centerp(2)
Call ThisDrawing.ModelSpace.AddLine(clpoint1, clpoint2)
1 E( `; V9 N4 |3 c& Iclpoint1(0) = centerp(0): clpoint1(1) = centerp(1) - 10 - wj / 2: clpoint1(2) = centerp(2)
" Z" q2 G! b- O, }0 ~clpoint2(0) = centerp(0): clpoint2(1) = centerp(1) + 10 + wj / 2: clpoint2(2) = centerp(2)
  m0 y9 \7 b! ^! zCall ThisDrawing.ModelSpace.AddLine(clpoint1, clpoint2)
clpoint1(0) = centerp(0): clpoint1(1) = ent.Center(1) - 10 - kj / 2: clpoint1(2) = centerp(2)
+ `! A3 K* n$ o2 y' Q) wclpoint2(0) = centerp(0): clpoint2(1) = ent.Center(1) + 10 + kj / 2: clpoint2(2) = centerp(2)
Dim lent As AcadLine
2 G; B4 {" \* Q+ d8 {Set lent = ThisDrawing.ModelSpace.AddLine(clpoint1, clpoint2)
lent.ArrayPolar kgs, 2 * 3.1415926, centerp
lent.Delete
ent.Delete
4 e# h- l' A& iThisDrawing.ActiveLayer = oldlay '把当前图层还原
: ~3 s4 y/ }: b" v5 b# S1 eZoomExtents '显示整个图形
End Sub

jshailin

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

woaishuijia

这个程序如果自用，已经完全可以了。如果共享则还有些不太合理的地方：
. l0 F) q: U7 e" I4 J1、
wj = ThisDrawing.Utility.GetReal("外径(0～10000)<520>") '输入外径尺寸
If Err.Number <> 0 Then '用户输入的不是有效的数字
wj = 520
) @: ^# \7 m: {; b9 e  cErr.Clear '清除错误
- O+ X* a* V  c' F# TEnd If
及后面类似获取数值的部分
如果用户输入的是负值怎么办？如果用户想按“Esc”退出命令怎么办？

- R  `5 d! i9 X9 f+ E2、
centerp = ThisDrawing.Utility.GetPoint(, "定位法兰中心：") '设定中心坐标
如果用户没有输入点坐标而直接按回车、空格或按“Esc”怎么办？

* n" b$ n; h9 g% I还有一些小的瑕疵，比如：
Set ent = ThisDrawing.ModelSpace.AddCircle(centerp, kj / 2) '画一个小孔
Dim centerm(0 To 2) As Double '移动坐标
centerm(0) = centerp(0): centerm(1) = centerp(1) + zxj / 2: centerm(2) = centerp(2)
; _8 H- i& Z) t# ~7 v4 z# h% lent.Move centerp, centerm
2 f- ^, k4 X8 p1 }为什么不直接把小孔画在centerm呢？
. @+ S5 }& @" |5 t6 G; B$ u6 L
9 r- k9 A" D, d- W4 \9 K- z还有，建议你把VBA编辑器中“选项”对话框下“编辑器”选项卡的“要求变量声明”勾选上，以后不要用隐式声明变量，这可以避免低级错误。
7 N& u- _( }% x& L# i4 g
( c  U  v5 z) s友情提示：“GetReal”、“GetInteger”和“GetPoint”方法按下空格或回车的错误代码是-2145320928

nanisan

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

yurenai85

楼主好心人，我急用呢

antaixjh

厉害厉害！！！

antaixjh

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

tongji007

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

魔域罗兰

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

qjydz

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

raymondou

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

zhuguiping

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