方圓孔圓周分佈-宏

ryouss · 发表于 2018-5-30 23:27:37

马上注册，结识高手，享用更多资源，轻松玩转三维网社区。

您需要登录才可以下载或查看，没有帐号？注册

x

本帖最后由 ryouss 于 2018-6-1 10:47 编辑

http://www.3dportal.cn/discuz/fo ... 5258&extra=page%3D2

1. 這是如上的升級版,在 pyczt大大的指導下改進了不管XY為正負值或是0皆可執行,
並新增加打方孔.
2. 個人覺得宏的執行功能在应用上是較為其次,反而是給新入門有心學習宏的是不錯的範例.
3. 可能尚有其他未發現問題有興趣者試試了.
注意事項:
1.首圈半徑限制不能小於等於鉆孔直徑,也不能小於方孔邊長的1.5倍(避免破孔或是零厚度).
2.草圖上不要用網格,避免取點時被吸附至網點.

附SWP文件

Circle distribution_0530.rar (48.83 KB, 下载次数: 38)

2018-5-30 23:25 上传

点击文件名下载附件

' *************************************************************
- K2 X# _& Q6 f) \4 A
' macro recorded on 05/28/18 by scliang( s( }# r6 A/ Y& {$ P
' 功能:方圓孔圓周分佈,本範例因是用除料拉伸,所以鉆孔是平底.
. D& o4 j& E; D$ L, Q/ z% k
' 操作:1.在零件先選取要打孔之平面.( t3 R1 O$ N p8 d2 K2 w4 o
' 2.執行 "main" .
" ]! U/ L4 t. u2 V5 P8 z2 K- _2 f
' 3.選取打孔類別,TextBox(文本框)鍵入相關參數值.) g0 ^8 d6 u7 J3 }4 D
' 4.首圈半徑近似於相鄰兩孔之中心(弧長)距離.
& k1 `# C- `+ |6 ?+ h1 |
' 5.方孔邊長=圓孔直徑., d6 n* X# y" a; D1 t6 P6 e1 d
' 注意事項:起始圓半徑限制不能小於等於鉆孔直徑,也不能小於方孔邊長的1.5倍
3 O" x* s* p% Z% s) l" S/ B
') P* G5 W3 E; o9 c
' *************************************************************
8 @3 a5 t- B' T- H5 W+ |
3 f1 i) |( `* a7 s
Dim A1X As Double 'TextBox1
. m. Y, a, [* W7 W; C+ }$ u
Dim A1Y As Double 'TextBox2. \1 N6 L: D6 H! K L9 M
Dim A2X As Double2 G$ c0 b8 f# B/ Q; d
Dim A3X As Double5 q" r5 D1 ^5 D O4 O; h, a
Dim A3Y As Double
' y8 {/ R4 _0 a6 T
Dim B1X As Double
4 B$ U$ U0 _5 @) s
Dim B1Y As Double) {# V' ~* O$ { }( \/ a, ?0 Y q3 R
Dim B2X As Double, j0 p4 d) |. ]1 ]2 d( d7 O
Dim B2Y As Double+ s3 c' Q. U2 d+ x' x
Dim B3X As Double0 L+ R: J! T# y E
Dim B3Y As Double
/ h7 H0 x Y: T1 D' x
Dim D As Double 'TextBox3
5 K5 H6 |" r- D. S/ a4 G
Dim R1 As Double 'TextBox4
f+ B3 o0 j% P
Dim Drill_depth As Double 'TextBox5; X c) {) r. d; _. @+ K1 p! S" z
Dim Circle_number As Integer 'TextBox6
3 l+ t: I+ J, V! q+ s
Dim i As Integer% {; ?4 Y, k1 A+ @1 v
Dim Class_ As Integer
1 g8 b- B( z7 ^7 k2 ^
Dim pi As Double/ Z: C2 @/ I3 w# `: V- T
Dim RN As Double. U. D( O/ ?* P' W
Dim ArcRadius As Double1 N" x5 r9 J8 S% s( z% @
Dim ArcAngle As Double
8 V' J/ H) @! U) o, ]3 Q
" e6 L$ W( d! M7 f6 A4 v
Sub main()( K. S3 d, F# M# Z
UserForm1.Show 01 J: D0 z! u* M3 \; n: k
End Sub
0 d& O0 _9 n/ l* O1 V! k2 U( F
Sub Draw()
@/ ]5 X) f" S
With UserForm1
* n& u3 I2 e9 q9 W
.Label8.Caption = ""
1 A+ m4 c& O# m7 v* u: U% e
Class_ = .ComboBox1.ListIndex '孔類代碼 0-->圓孔,1-->方孔/ j& ?# F, w8 s C& L3 c! E# t
'判定資料是否沒打入: D/ _5 |! R" X. U
If .TextBox3.Value = "" Or .TextBox4.Value = "" Or .TextBox5.Value = "" Or .TextBox6.Value = "" Then
: z* W7 c6 a- t
MsgBox ("Enter empty")" y. u; ]9 q# `9 R& z
Exit Sub8 y' r1 F6 W8 h% [. b9 P4 J
End If2 R8 t" ?& G( u; g
'判定資料是否是輸入錯誤(起始圓半徑限制不能小於等於鉆孔直徑,也不能小於方孔邊長的1.5倍)( t8 Y# _! i/ v
D = .TextBox3.Value / 1000 '孔直徑=方孔邊長5 ^- E% }# S/ @3 D9 p5 c3 P
R1 = .TextBox4.Value / 1000 '首圈中心半徑
5 k5 ?9 o9 u/ s0 j! N
If (Class_ = 0 And D >= R1) Or (Class_ = 1 And R1 / D < 1.4999) Then
- k( |8 ^ \1 a( }. F- Z
MsgBox ("Data error")9 @4 J$ ]7 X( ?% `
Exit Sub" i: p5 ~% D- @4 c! _; |
End If
# g: F. n1 }" C
~; r( i2 m7 e8 ?
Set swApp = Application.SldWorks- [' r4 k/ u! B8 ?) U, p5 i
Set Part = swApp.ActiveDoc0 H3 t' ~5 h; ?/ g& P7 Z, L3 M
Set swSketchMgr = Part.SketchManager
b5 x5 I9 ~- y6 ?5 m7 _2 K0 C
Part.SketchManager.InsertSketch True '依據選取面插入草圖
. a0 M& U2 u/ C$ o# h% w e
Part.SketchManager.AddToDB True '草圖實體直接添加到數據庫(否則 x<=0 會有問題)
$ z8 e' r" M) ]
'中心圓之座標及作圖
; x/ R! x+ Q# F" n* P5 |
A1X = .TextBox1.Value / 1000 '圓周複製中心 X 座標
8 v1 O; B5 H" Z; V _: B/ e6 }* \
A1Y = .TextBox2.Value / 1000 '圓周複製中心 Y 座標* {% ]# X( T) \( y/ f
A2X = A1X + D / 2 '中心圓之半徑 X 座標
* S3 P0 u5 \4 f1 R# i4 t- i
pi = Atn(1) * 4
7 P5 ^7 ^" _+ }% z0 \( D$ @, r
Circle_number = .TextBox6.Value '複製圈數. S! d9 v- Z8 p* Z" O1 o4 \+ \7 d
Drill_depth = .TextBox5.Value / 1000 '鉆孔深
+ ~7 Q1 J' o3 S* ~8 `. }
'判定孔類之圓周分佈打孔
0 U5 F% ? S8 W& H( R
Select Case Class_6 j8 v+ r( Y, B$ B+ B
Case 0 '打圓孔( e# h- |/ N# G- M' j! s1 o
Set swSketchSegment = swSketchMgr.CreateCircle(A1X, A1Y, 0#, A2X, A1Y, 0#) '作中心圓& n4 x6 O; ?# N, z
For i = 1 To Circle_number
* ]) a' I5 q2 _5 g6 I
RN = i * R1 '分佈圓周之半徑
" H) M4 G: Z3 v0 Y
copy_number = Int(2 * RN * pi / R1 + 0.5) '分佈圓周之鉆孔數
9 o* w% A! W' F% W5 ?
Totle_drill_hole = Totle_drill_hole + copy_number '累加各圈孔數7 q- W# p; M3 ]
'分佈圓之基圓作圖# _3 w6 @; P/ W+ N- H
B1X = A1X + RN6 j/ l8 a" h" c- c, P0 Y8 S
B2X = B1X + D / 2
' i' C: ?( `; Y
Set swSketchSegment = swSketchMgr.CreateCircle(B1X, A1Y, 0#, B2X, A1Y, 0#) '各圈基孔
1 {$ {8 S% V' B" S" u4 [
'分佈圓之複製孔數,圓周複製參數:圓弧半徑、圓弧角、複製數、孔間距(間隔弧度)、圖案旋轉、刪除實例
. G% A9 X9 A5 }0 l. n/ o0 a
boolstatus = swSketchMgr.CreateCircularSketchStepAndRepeat(RN, pi, copy_number, 2 * pi, True, "", True, True, True)
+ i# |$ V- r- Y' U* R4 Z
Next+ s* b2 {9 Y0 [5 ?# j8 k
8 S' G( l Z2 B5 P
Case 1 '打方孔& i* h1 J% g1 O6 E, S6 u2 t
A3X = A1X - D / 2
+ ?8 p: I `+ }6 d8 u
A3Y = A1Y + D / 2
- A% {+ Q; K D
vSkLines = swSketchMgr.CreateCenterRectangle(A1X, A1Y, 0#, A3X, A3Y, 0#) '中心方孔6 i" A3 A7 Y. F) B
'~~~ 約束共點之初值 ~~~
+ ?7 H% @7 V5 k! ^9 B, K
Dim NamePoint As String6 |( D6 F h( s# }. ^# Q
Dim NumPoint As Integer
' i$ ]1 d' S$ y2 ^
If A1X = 0 And A1Y = 0 Then7 I( C/ @! X, t+ i- M- v
NumPoint = 65 X. y8 m2 C' {
Else, B& p+ {& g. j/ ~5 `/ D* w
NumPoint = 5' t3 n& p$ n% i) |# V9 x& ^
End If/ I% o# _- K0 _ @$ _
'~~~~~~~~~~~~~~~~~/ ^% U* U/ [+ f( |; P: v) k/ b+ K
For i = 1 To Circle_number" t' j4 b$ K' [, Z- e1 Y: y+ k9 @4 Z
'中心圓之座標及作圖
/ J( Y: u% S2 I& y% J! `; o
RN = i * R1 '分佈圓周之半徑
8 h9 E, K! k% l/ |
B1X = A1X + RN
% a+ B3 r7 K2 @& d
B1Y = A1Y
- V, [! j, T( t# Q, s$ m0 `( V, @
B3X = B1X - D / 2) ]; C7 \3 B& t$ f( x2 i' B
B3Y = A3Y
" ]- }6 g* z K) A! u
" t7 f; l* ~1 ?
vSkLines = swSketchMgr.CreateCenterRectangle(B1X, B1Y, 0, B3X, B3Y, 0) '各圈基準方孔
3 }" E8 M; r" j$ S1 V9 `# o. n' w
ArcAngle = pi - Atn(D / 2 / (RN - D / 2)) '圓周複製弧角1 D3 X- F! w! k/ R5 t4 I9 a4 |
ArcRadius = Sqr((D / 2) ^ 2 + (RN - D / 2) ^ 2) '圓周複製半徑
2 a5 H$ V7 p. S. j
copy_number = Int(2 * RN * pi / R1 + 0.5) '複製數
2 R# z& i2 o( V- ]; x
'Debug.Print copy_number
& G$ I1 y5 N0 C
NumPoint = NumPoint + 5 * copy_number + 1 '點計數
) q: {9 ~# o5 }; |8 A2 Y
Totle_drill_hole = Totle_drill_hole + copy_number- ]% d9 K0 O: L
boolstatus = swSketchMgr.CreateCircularSketchStepAndRepeat(ArcRadius, ArcAngle, copy_number, 2 * pi, False, "", False, False, False)
( E; o+ X- y: n) d% K3 T, F9 z
NamePoint = "Point" & NumPoint5 O5 m, w1 `7 s
'Debug.Print NamePoint7 ~- _) Y4 r8 e+ U$ Q
Part.Extension.SelectByID2 NamePoint, "SKETCHPOINT", 0, 0, 0, False, 0, Nothing, 0 '圓周複製中心點
" h5 r5 x" l% L- ]
Part.Extension.SelectByID2 "Point1", "SKETCHPOINT", 0, 0, 0, True, 0, Nothing, 0 '輸入的XY座標點
% u: g6 o0 B: N' g5 O5 W g+ f) E
Part.SketchAddConstraints "sgCOINCIDENT" '取圓周複製中心點和輸入的XY座標點 "共點約束"
* X4 I: F0 Q+ ~' v9 I1 H
Part.ClearSelection2 True, {4 \: Y0 H. k- a) `& B2 w% @ Y
Next
$ ~( Z8 t* y* d
End Select
, N d) u( I5 N7 L4 t
1 z! o+ Q) s; }
.Label8.Caption = 1 + Totle_drill_hole '總鉆孔數
S& ~1 @5 [/ y$ v( \$ L/ Y
End With
, B/ ]6 T' B! [2 U; l1 e
Part.SketchManager.AddToDB False
7 D$ ^7 \# F! Q" ^! W. Y5 _! ~
'除料拉伸
( s/ K& ]8 T* y
Dim myFeature As Object1 G# e6 N) {. ?/ p4 Y6 I
Set myFeature = Part.FeatureManager.FeatureCut3(True, False, False, 0, 0, Drill_depth, 0, False, False, False, False, 1.74532925199433E-02, _
) x$ ?9 M3 A6 y& j/ t2 T
1.74532925199433E-02, False, False, False, False, False, True, True, True, True, False, 0, 0, False)" G2 S& v" i5 H% A" L' Z4 E
End Sub

复制代码

licoolicoo · 发表于 2018-5-31 08:17:32

楼主，方孔上能不能带个R角设置

ryouss · 发表于 2018-5-31 08:28:26

本帖最后由 ryouss 于 2018-5-31 10:27 编辑

licoolicoo 发表于 2018-5-31 08:17
- a* }7 V# r* } W t5 j楼主，方孔上能不能带个R角设置

謝謝你的建議.
沒有帶R角編程就碰到好些問題,
再帶個R角這要試試了...

txz1314 · 发表于 2018-5-31 17:09:23

liang大SW2018无法运行

ryouss · 发表于 2018-5-31 17:16:39

txz1314 发表于 2018-5-31 17:09: N4 O& I/ g0 `' e
liang大SW2018无法运行

謝謝測試

我沒2018可試,不知錯誤情況如何?

ryouss · 发表于 2018-6-1 08:17:11

追蹤一下,有人測試成功的嗎?

zqm · 发表于 2018-6-1 14:14:26

ryouss 发表于 2018-6-1 08:17
& V+ S2 w5 m& h! M追蹤一下,有人測試成功的嗎?

2017下通过测试，有些变动，传下附件。弱弱问下语言怎么改？

ryouss · 发表于 2018-6-1 14:45:03

zqm 发表于 2018-6-1 14:14
7 c7 l3 ^+ \! I3 M- K2017下通过测试，有些变动，传下附件。弱弱问下语言怎么改？

http://www.3dportal.cn/discuz/fo ... ead&tid=1494298

VBA宏繁簡字的更改,參看如上 7#

zqm · 发表于 2018-6-4 09:50:26

本帖最后由 zqm 于 2018-6-4 10:12 编辑

ryouss 发表于 2018-6-1 14:45/ f5 a8 f9 u! [ j- h* _; P* l
http://www.3dportal.cn/discuz/forum.php?mod=viewthread&tid=1494298
" m' D5 H/ K2 r: f2 L8 J X4 ]3 x5 {% f. S0 Z3 N
VBA宏繁簡字的更改,參看如上 7 ...

梁大，我怎么用了那个简繁也转不过来。若不改，就调不出界面，出现如图2的情况。

ryouss · 发表于 2018-6-4 13:25:51

zqm 发表于 2018-6-4 09:50/ N; k0 I8 R. Y S1 k& a
梁大，我怎么用了那个简繁也转不过来。若不改，就调不出界面，出现如图2的情况。

如下三步操作

zqm · 发表于 2018-6-4 16:56:05

ryouss 发表于 2018-6-4 13:25: C' i2 ]" R9 U
如下三步操作

跟着梁大学习就是爽，终于解决了，多谢梁大。

bush9898 · 发表于 2018-6-7 09:26:06

11楼的朋友：能把转换简体的宏传上来吗？谢谢

zqm · 发表于 2018-6-7 10:14:08

bush9898 发表于 2018-6-7 09:26
& u7 E) X5 j" _1 n2 v) o$ ?2 X$ e11楼的朋友：能把转换简体的宏传上来吗？谢谢

应楼上的要求，上传了。

bush9898 · 发表于 2018-6-7 11:17:28

谢谢12楼！

linkral · 发表于 2018-6-30 14:50:26

代码本来想用下的，一复制一堆的乱码简直强迫症了

kimtuyendcn · 发表于 2018-7-17 14:23:21

That's nice, thank you

13993359550 · 发表于 2018-7-18 21:36:41

多谢梁大，学习了

machine134 · 发表于 2018-7-18 21:46:48

zqm 发表于 2018-6-7 10:14
$ |4 p1 d% D/ v: N' I应楼上的要求，上传了。

谢谢分享，我也学习学习

machine134 · 发表于 2018-7-18 23:37:34

谢谢分享，下载这个在17版本能运行

清风直夏 · 发表于 2018-11-13 08:37:33

感谢分享

		自动登录	找回密码
密码			注册

全站		goto3d 说: 版主微信号：caivin811031；还未入三维微信群的小伙伴，速度加	2022-07-04
全站		goto3d 说: 此次SW竞赛获奖名单公布如下，抱歉晚了，版主最近太忙：一等奖：塔山817；二等奖：a9041、飞鱼；三等奖：wx_dfA5IKla、xwj960414、bzlgl、hklecon；请以上各位和版主联系，领取奖金！！！	2022-03-11

通知

[分享] 方圓孔圓周分佈-宏

马上注册，结识高手，享用更多资源，轻松玩转三维网社区。

评分

点评

点评

点评

点评