方圆孔圆周分布-宏 - iCAx开思网

' *************************************************************
' macro recorded on 05/20/28 by scliang
' 功能:圓周分佈方圓孔,本範例因是用除料拉伸,所以鉆孔是平底.
' 操作: 1.在零件先選取要打孔之平面.
' 2.執行 "main" .
' 3.TextBox 鍵入相關參數值.
' 4.首圈半徑近似於相鄰兩孔之中心(弧長)距離.
' 5.方孔邊長=圓孔直徑.
'
' *************************************************************
Dim A1X As Double 'TextBox1
Dim A1Y As Double 'TextBox2
Dim A2X As Double
Dim A3X As Double
Dim A3Y As Double
Dim B1X As Double
Dim B1Y As Double
Dim B2X As Double
Dim B2Y As Double
Dim B3X As Double
Dim B3Y As Double
Dim D As Double 'TextBox3
Dim R1 As Double 'TextBox4
Dim Drill_depth As Double 'TextBox5
Dim Circle_number As Integer 'TextBox6
Dim i As Integer
Dim Class_ As Integer
Dim pi As Double
Dim RN As Double
Dim ArcRadius As Double
Dim ArcAngle As Double
Sub main()
UserForm1.Show 0
End Sub
Sub Draw()
With UserForm1
Class_ = .ComboBox1.ListIndex '孔類代碼 0-->圓孔,1-->方孔
'判定資料是否沒打入
If .TextBox1.value = "" Or .TextBox2.value = "" Or .TextBox3.value = "" Or .TextBox4.value = "" Or .TextBox5.value = "" Or .TextBox6.value = "" Then
MsgBox ("Enter empty")
Exit Sub
End If
'判定資料是否是輸入錯誤(起始圓半徑限制不能小於等於鉆孔直徑,也不能小於方孔邊長的1.5倍)
D = .TextBox3.value / 1000 '孔直徑=方孔邊長
R1 = .TextBox4.value / 1000 '首圈中心半徑
If (Class_ = 0 And D >= R1) Or (Class_ = 1 And R1 / D < 1.4999) Then
MsgBox ("Data error")
Exit Sub
End If
Set swApp = Application.SldWorks
Set Part = swApp.ActiveDoc
Set swSketchMgr = Part.SketchManager
Part.SketchManager.InsertSketch True '依據選取面插入草圖
Part.SketchManager.AddToDB True '草圖實体直接添加到數据庫(否則 x<=0 會有問題)
'中心圓之座標及作圖
A1X = .TextBox1.value / 1000 '圓周複製中心 X 座標
A1Y = .TextBox2.value / 1000 '圓周複製中心 Y 座標
A2X = A1X + D / 2 '中心圓之半徑 X 座標
pi = Atn(1) * 4
Circle_number = .TextBox6.value '複製圈數
Drill_depth = .TextBox5.value / 1000 '鉆孔深
'判定孔類之圓周分佈打孔
Select Case Class_
Case 0 '打圓孔
Set swSketchSegment = swSketchMgr.CreateCircle(A1X, A1Y, 0#, A2X, A1Y, 0#) '作中心圓
For i = 1 To Circle_number
RN = i * R1 '分佈圓周之半徑
Copy_Number = Int(2 * RN * pi / R1 + 0.5) '分佈圓周之鉆孔數
Totle_drill_hole = Totle_drill_hole + Copy_Number '累加各圈孔數
'分佈圓之基圓作圖
B1X = A1X + RN
B2X = B1X + D / 2
Set swSketchSegment = swSketchMgr.CreateCircle(B1X, A1Y, 0#, B2X, A1Y, 0#) '各圈基孔
'分佈圓之複製孔數,圓周複製參數:圓弧半徑、圓弧角、複製數、孔間距(間隔弧度)、圖案旋轉、刪除實例
boolstatus = swSketchMgr.CreateCircularSketchStepAndRepeat(RN, pi, Copy_Number, 2 * pi, True, "", True, True, True)
Next
Case 1 '打方孔
A3X = A1X - D / 2
A3Y = A1Y + D / 2
vSkLines = swSketchMgr.CreateCenterRectangle(A1X, A1Y, 0#, A3X, A3Y, 0#) '中心方孔
'Stop
For i = 1 To Circle_number
'中心圓之座標及作圖
RN = i * R1 '分佈圓周之半徑
B1X = A1X + RN
B1Y = A1Y
B3X = B1X - D / 2
B3Y = A3Y
vSkLines = swSketchMgr.CreateCenterRectangle(B1X, B1Y, 0, B3X, B3Y, 0) '各圈基準方孔
ArcAngle = pi - Atn(D / 2 / (RN - D / 2)) '圓周複製弧角
ArcRadius = Sqr((D / 2) ^ 2 + (RN - D / 2) ^ 2) '圓周複製半徑
Copy_Number = Int(2 * RN * pi / R1 + 0.5) '複製數
Totle_drill_hole = Totle_drill_hole + Copy_Number
boolstatus = swSketchMgr.CreateCircularSketchStepAndRepeat(ArcRadius, ArcAngle, Copy_Number, 2 * pi, False, "", False, False, False)
Next
End Select
.Label8.Caption = 1 + Totle_drill_hole '總鉆孔數
End With
Part.SketchManager.AddToDB False
'除料拉伸
Dim myFeature As Object
Set myFeature = Part.FeatureManager.FeatureCut3(True, False, False, 0, 0, Drill_depth, 0, False, False, False, False, 1.74532925199433E-02, _
1.74532925199433E-02, False, False, False, False, False, True, True, True, True, False, 0, 0, False)
End Sub

复制代码