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

jshailin

Sub falan()
Dim centerp As Variant '中心坐标
Dim templay As AcadLayer '定义临时层
/ A3 L2 S" G; F; w7 |Dim lay0 As AcadLayer '定义粗实线层
Dim lay1 As AcadLayer '定义中心线层
5 w; f  G3 ^8 b6 K- O% _Dim oldlay As AcadLayer '定义原来的层
Dim ent As AcadCircle '定义对象
$ ?  g. g. Y4 O2 Q( j" _$ jOn Error Resume Next
wj = ThisDrawing.Utility.GetReal("外径(0～10000)<520>") '输入外径尺寸
7 \+ D& a, M0 u" E0 J9 \/ rIf Err.Number <> 0 Then '用户输入的不是有效的数字
3 B+ o2 [+ h/ M0 [7 s& L7 K   wj = 520
3 k, F- M5 B4 e   Err.Clear '清除错误
# D' w# C% m- b- a2 yEnd If
nj = ThisDrawing.Utility.GetReal("内径(0～10000)<380>") '输入内径尺寸
If Err.Number <> 0 Then '用户输入的不是有效的数字
8 i+ j$ b+ i1 r8 s1 l   nj = 380
) A- k. ]9 [  X! A6 P* L) Y   Err.Clear '清除错误
End If
7 Y9 D2 s6 k% d$ f5 ?4 l- nzxj = ThisDrawing.Utility.GetReal("周围孔中心直径(0～10000)<480>") '输入周围孔中心直径尺寸
/ g% p3 {! s% [5 GIf Err.Number <> 0 Then '用户输入的不是有效的数字
# _  x6 z# J" b% I   zxj = 480
" P6 c7 I6 t, C. u# U   Err.Clear '清除错误
End If
kj = ThisDrawing.Utility.GetReal("周围孔径(0～100)<24>") '输入周围孔径尺寸
& M# p+ ?# A! ZIf Err.Number <> 0 Then '用户输入的不是有效的数字
. V5 ]% F/ t- N2 T0 H   kj = 24
   Err.Clear '清除错误
End If
/ ~. c5 F+ k& s3 r' G! Ykgs = ThisDrawing.Utility.GetInteger("周围孔个数(0～100)<12>") '输入周围孔个数
If Err.Number <> 0 Then '用户输入的不是有效的数字
( V& S2 b9 P" ^4 k. h+ S( W& [1 p   kgs = 12
   Err.Clear '清除错误
End If
% \* j9 N, c8 c3 f' C5 wkgs = kgs + 1
centerp = ThisDrawing.Utility.GetPoint(, "定位法兰中心：") '设定中心坐标
7 h' y7 r$ N# P1 M  Z. iSet oldlay = ThisDrawing.ActiveLayer '记住当前图层
9 w! S7 f3 V  uFor Each templay In ThisDrawing.Layers '查找图层名为1的图层
. `- U" ~. T, i! I6 E7 p( r    If templay.Name = "1" Then
        Set lay0 = templay '找出图层名为1的为粗线层
    End If
. Q: g4 q+ G* _  L: {4 P' V    If templay.Name = "0" Then
( n+ D& e) j& j( i0 E% v7 {+ m4 f. H        Set lay1 = templay '找出图层名为0的为中心线层
, @& \; k5 ?  G' w    End If
Next templay
   
ThisDrawing.ActiveLayer = lay0 '把当前图层设为粗线层
Call ThisDrawing.ModelSpace.AddCircle(centerp, wj / 2) '画外圆圈
# Y; R0 b1 w8 @6 g9 vCall ThisDrawing.ModelSpace.AddCircle(centerp, nj / 2) '画内圆圈
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)

' V# o9 O: d" SDim rent As Variant
ent.Move centerp, centerm
; i" o- P; _1 j4 i5 f'rent = ent.ArrayPolar(kgs, 2 * pi, centerp)
. U; U9 S0 L, o8 d& o- ?) }ent.ArrayPolar kgs, 2 * 3.1415926, centerp

3 v# G- w# c3 `! L& y. Y! BThisDrawing.ActiveLayer = lay1 '把当前图层设为中心线层
Call ThisDrawing.ModelSpace.AddCircle(centerp, zxj / 2) '画外圆圈
6 H. v1 S: C& b- T! E9 l" w% pDim clpoint1(0 To 2) As Double '坐标
Dim clpoint2(0 To 2) As Double '坐标
( ^( C5 ^$ z# n% o2 C9 i3 X9 Zclpoint1(0) = centerp(0) - 10 - wj / 2: clpoint1(1) = centerp(1): clpoint1(2) = centerp(2)
9 r" N/ ^  B9 ]8 @* x; D; G1 Vclpoint2(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)
: M+ O4 K4 c% Uclpoint2(0) = centerp(0): clpoint2(1) = centerp(1) + 10 + wj / 2: clpoint2(2) = centerp(2)
, P% s/ l+ e# t* U2 L+ w' xCall ThisDrawing.ModelSpace.AddLine(clpoint1, clpoint2)
- F4 A8 N, c4 g8 O2 ]" U3 ]* y$ Kclpoint1(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)
Dim lent As AcadLine
Set lent = ThisDrawing.ModelSpace.AddLine(clpoint1, clpoint2)
lent.ArrayPolar kgs, 2 * 3.1415926, centerp
lent.Delete
! l( |6 N) B; m4 c( d5 C, ient.Delete
, ~7 c" t+ c$ H, oThisDrawing.ActiveLayer = oldlay '把当前图层还原
+ c+ E. P' A8 ^ZoomExtents '显示整个图形
End Sub

jshailin

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

woaishuijia

这个程序如果自用，已经完全可以了。如果共享则还有些不太合理的地方：
1、
wj = ThisDrawing.Utility.GetReal("外径(0～10000)<520>") '输入外径尺寸
If Err.Number <> 0 Then '用户输入的不是有效的数字
wj = 520
9 w: b$ T# j4 a% X( G' ^  tErr.Clear '清除错误
End If
0 {+ {  q) x- d及后面类似获取数值的部分
如果用户输入的是负值怎么办？如果用户想按“Esc”退出命令怎么办？

% s: U! ]# [4 U' ^2 j2、
9 h$ r- n% J5 U* Rcenterp = ThisDrawing.Utility.GetPoint(, "定位法兰中心：") '设定中心坐标
如果用户没有输入点坐标而直接按回车、空格或按“Esc”怎么办？

还有一些小的瑕疵，比如：
Set ent = ThisDrawing.ModelSpace.AddCircle(centerp, kj / 2) '画一个小孔
Dim centerm(0 To 2) As Double '移动坐标
4 |9 N/ m: f+ A3 e+ M; x0 W! {centerm(0) = centerp(0): centerm(1) = centerp(1) + zxj / 2: centerm(2) = centerp(2)
4 T1 T3 w5 j1 Y+ X3 Yent.Move centerp, centerm
为什么不直接把小孔画在centerm呢？
% z0 W1 X/ e4 u1 v+ n% b8 m0 x- f
还有，建议你把VBA编辑器中“选项”对话框下“编辑器”选项卡的“要求变量声明”勾选上，以后不要用隐式声明变量，这可以避免低级错误。
2 H6 C; C. d/ {! W) j: }1 ^& t
友情提示：“GetReal”、“GetInteger”和“GetPoint”方法按下空格或回车的错误代码是-2145320928

nanisan

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

yurenai85

楼主好心人，我急用呢

antaixjh

厉害厉害！！！

antaixjh

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

tongji007

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

魔域罗兰

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

qjydz

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

raymondou

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

zhuguiping

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