找回密码 注册 QQ登录
开思网工业级高精度在线3D打印服务

iCAx开思网

CAD/CAM/CAE/设计/模具 高清视频【积分说明】如何快速获得积分?快速3D打印 手板模型CNC加工服务在线3D打印服务,上传模型,自动报价
查看: 2485|回复: 14
打印 上一主题 下一主题

[讨论] 方圆孔圆周分布-宏

[复制链接]
跳转到指定楼层
1
发表于 2018-5-29 14:14:07 | 只看该作者 回帖奖励 |倒序浏览 |阅读模式
本帖最后由 ryouss 于 2018-5-30 09:37 编辑

https://www.icax.org/thread-1258414-1-1.html

這是如上的升級版,圆孔圆周分布沒問題后想再試試正方孔,結果還是出現一些無法理解的問題.
有興趣者試試了,看是否能修改程式改善問題.
附SWP檔  

  1. ' *************************************************************
  2. ' macro recorded on 05/20/28 by scliang
  3. ' 功能:圓周分佈方圓孔,本範例因是用除料拉伸,所以鉆孔是平底.
  4. ' 操作: 1.在零件先選取要打孔之平面.
  5. '       2.執行 "main" .
  6. '       3.TextBox 鍵入相關參數值.
  7. '       4.首圈半徑近似於相鄰兩孔之中心(弧長)距離.
  8. '       5.方孔邊長=圓孔直徑.
  9. '
  10. ' *************************************************************

  11. Dim A1X As Double 'TextBox1
  12. Dim A1Y As Double 'TextBox2
  13. Dim A2X As Double
  14. Dim A3X As Double
  15. Dim A3Y As Double
  16. Dim B1X As Double
  17. Dim B1Y As Double
  18. Dim B2X As Double
  19. Dim B2Y As Double
  20. Dim B3X As Double
  21. Dim B3Y As Double
  22. Dim D As Double 'TextBox3
  23. Dim R1 As Double 'TextBox4
  24. Dim Drill_depth As Double 'TextBox5
  25. Dim Circle_number As Integer 'TextBox6
  26. Dim i As Integer
  27. Dim Class_ As Integer
  28. Dim pi As Double
  29. Dim RN As Double
  30. Dim ArcRadius As Double
  31. Dim ArcAngle As Double

  32. Sub main()
  33. UserForm1.Show 0
  34. End Sub

  35. Sub Draw()
  36. With UserForm1
  37. Class_ = .ComboBox1.ListIndex  '孔類代碼 0-->圓孔,1-->方孔
  38. '判定資料是否沒打入
  39. If .TextBox1.value = "" Or .TextBox2.value = "" Or .TextBox3.value = "" Or .TextBox4.value = "" Or .TextBox5.value = "" Or .TextBox6.value = "" Then
  40.       MsgBox ("Enter empty")
  41.       Exit Sub
  42. End If
  43. '判定資料是否是輸入錯誤(起始圓半徑限制不能小於等於鉆孔直徑,也不能小於方孔邊長的1.5倍)
  44. D = .TextBox3.value / 1000 '孔直徑=方孔邊長
  45. R1 = .TextBox4.value / 1000 '首圈中心半徑
  46. If (Class_ = 0 And D >= R1) Or (Class_ = 1 And R1 / D < 1.4999) Then
  47.       MsgBox ("Data error")
  48.       Exit Sub
  49. End If

  50. Set swApp = Application.SldWorks
  51. Set Part = swApp.ActiveDoc
  52. Set swSketchMgr = Part.SketchManager
  53. Part.SketchManager.InsertSketch True '依據選取面插入草圖
  54. Part.SketchManager.AddToDB True  '草圖實体直接添加到數据庫(否則 x<=0 會有問題)
  55. '中心圓之座標及作圖
  56. A1X = .TextBox1.value / 1000 '圓周複製中心 X 座標
  57. A1Y = .TextBox2.value / 1000 '圓周複製中心 Y 座標
  58. A2X = A1X + D / 2 '中心圓之半徑 X 座標
  59. pi = Atn(1) * 4
  60. Circle_number = .TextBox6.value '複製圈數
  61. Drill_depth = .TextBox5.value / 1000 '鉆孔深
  62. '判定孔類之圓周分佈打孔
  63. Select Case Class_
  64. Case 0  '打圓孔
  65. Set swSketchSegment = swSketchMgr.CreateCircle(A1X, A1Y, 0#, A2X, A1Y, 0#) '作中心圓
  66. For i = 1 To Circle_number
  67.       RN = i * R1 '分佈圓周之半徑
  68.       Copy_Number = Int(2 * RN * pi / R1 + 0.5) '分佈圓周之鉆孔數
  69.       Totle_drill_hole = Totle_drill_hole + Copy_Number '累加各圈孔數
  70. '分佈圓之基圓作圖
  71.       B1X = A1X + RN
  72.       B2X = B1X + D / 2
  73.       Set swSketchSegment = swSketchMgr.CreateCircle(B1X, A1Y, 0#, B2X, A1Y, 0#) '各圈基孔
  74. '分佈圓之複製孔數,圓周複製參數:圓弧半徑、圓弧角、複製數、孔間距(間隔弧度)、圖案旋轉、刪除實例
  75.       boolstatus = swSketchMgr.CreateCircularSketchStepAndRepeat(RN, pi, Copy_Number, 2 * pi, True, "", True, True, True)
  76. Next

  77. Case 1 '打方孔
  78. A3X = A1X - D / 2
  79. A3Y = A1Y + D / 2
  80. vSkLines = swSketchMgr.CreateCenterRectangle(A1X, A1Y, 0#, A3X, A3Y, 0#) '中心方孔
  81. 'Stop
  82. For i = 1 To Circle_number
  83. '中心圓之座標及作圖
  84.       RN = i * R1 '分佈圓周之半徑
  85.       B1X = A1X + RN
  86.       B1Y = A1Y
  87.       B3X = B1X - D / 2
  88.       B3Y = A3Y
  89.       vSkLines = swSketchMgr.CreateCenterRectangle(B1X, B1Y, 0, B3X, B3Y, 0) '各圈基準方孔
  90.       ArcAngle = pi - Atn(D / 2 / (RN - D / 2)) '圓周複製弧角
  91.       ArcRadius = Sqr((D / 2) ^ 2 + (RN - D / 2) ^ 2) '圓周複製半徑
  92.       Copy_Number = Int(2 * RN * pi / R1 + 0.5) '複製數
  93.       Totle_drill_hole = Totle_drill_hole + Copy_Number
  94.       boolstatus = swSketchMgr.CreateCircularSketchStepAndRepeat(ArcRadius, ArcAngle, Copy_Number, 2 * pi, False, "", False, False, False)
  95. Next
  96. End Select

  97. .Label8.Caption = 1 + Totle_drill_hole '總鉆孔數
  98. End With
  99. Part.SketchManager.AddToDB False
  100. '除料拉伸
  101. Dim myFeature As Object
  102. Set myFeature = Part.FeatureManager.FeatureCut3(True, False, False, 0, 0, Drill_depth, 0, False, False, False, False, 1.74532925199433E-02, _
  103. 1.74532925199433E-02, False, False, False, False, False, True, True, True, True, False, 0, 0, False)
  104. End Sub
复制代码
在2012版測試正常(2017版測試失敗)


失敗(測試時圖形過小也容易失敗)


本帖子中包含更多资源

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

x
分享到:  QQ好友和群QQ好友和群 QQ空间QQ空间 腾讯微博腾讯微博 腾讯朋友腾讯朋友
收藏收藏1 分享淘帖 赞一下!赞一下!
2
发表于 2018-5-30 13:58:44 | 只看该作者

本帖子中包含更多资源

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

x

评分

参与人数 1贡献 +10 收起 理由
ryouss + 10 赞一个!

查看全部评分

3
 楼主| 发表于 2018-5-30 15:53:52 | 只看该作者

本帖子中包含更多资源

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

x
4
 楼主| 发表于 2018-5-30 15:54:52 | 只看该作者

本帖子中包含更多资源

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

x
5
发表于 2018-5-30 17:21:25 | 只看该作者

本帖子中包含更多资源

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

x

评分

参与人数 1贡献 +10 收起 理由
ryouss + 10 很给力!

查看全部评分

6
 楼主| 发表于 2018-5-30 18:58:31 | 只看该作者

马上注册,结交更多同行朋友,交流,分享,学习。

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

x
7
 楼主| 发表于 2018-5-30 19:19:20 | 只看该作者

本帖子中包含更多资源

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

x
8
发表于 2018-5-31 10:57:20 | 只看该作者

本帖子中包含更多资源

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

x
9
 楼主| 发表于 2018-5-31 20:52:31 | 只看该作者

本帖子中包含更多资源

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

x
10
发表于 2024-3-7 11:54:44 | 只看该作者

马上注册,结交更多同行朋友,交流,分享,学习。

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

x
您需要登录后才可以回帖 登录 | 注册

本版积分规则

3D打印手板模型快速制作服务,在线报价下单!

QQ 咨询|手机版|联系我们|iCAx开思网  

GMT+8, 2024-11-3 03:34 , Processed in 0.049890 second(s), 10 queries , Gzip On, Redis On.

Powered by Discuz! X3.3

© 2002-2024 www.iCAx.org

快速回复 返回顶部 返回列表