'
================================================
===============
' Build_Differential_Detailed_SW2024.vba
' Compatible: SolidWorks 2024
' Output: SLDPRT (ring/pinion răng th?ng), SLDASM, SLDDRW, optional STEP
'
================================================
===============
Option Explicit
' ---------------- USER PARAMETERS ----------------
Const R_MODULE_N As Double = 4#
Const R_PRESSURE As Double = 20#
Const R_SPIRAL As Double = 35# ' ch? tham chi?u (b?n này răng th?ng)
Const R_TEETH As Long = 43
Const P_TEETH As Long = 12
Const FACE_WIDTH As Double = 39#
Const RING_OD As Double = 180#
Const PINION_OFFSET As Double = 40#
Const SIDE_Z As Long = 20
Const SIDE_MOD As Double = 3#
Const SIDE_PRESSURE As Double = 20#
Const SIDE_FACE As Double = 21#
Const SIDE_PCD As Double = 63#
Const PLANET_Z As Long = 16
Const CASE_OD As Double = 220#
Const CASE_LEN As Double = 200#
Const CASE_WALL As Double = 10#
Const AXLE_STUB_D As Double = 24#
Const AXLE_STUB_LEN As Double = 80#
Const SIDE_OFFSET As Double = 80#
Const AXLE_TUBE_OFFSET As Double = 120#
Public EXPORT_STEP As Boolean ' đ?t ? Sub main()
' -------------------------------------------------
Dim swApp As [Link]
' ---------------- Helpers ----------------
Private Function MmToM(v As Double) As Double: MmToM = v / 1000#: End
Function
Private Function DegToRad(v As Double) As Double: DegToRad = v *
3.14159265358979 / 180#: End Function
Private Function EnsureDir(basePath As String) As String
Dim fso As Object: Set fso = CreateObject("[Link]")
If Not [Link](basePath) Then [Link] basePath
EnsureDir = basePath
End Function
Private Function DefaultOutDir() As String
Dim Wsh As Object, docs As String
Set Wsh = CreateObject("[Link]")
docs = [Link]("MyDocuments")
DefaultOutDir = EnsureDir(docs & "\ViSai_Diff_Detailed_SW")
End Function
Private Function NewPartDoc() As SldWorks.ModelDoc2
Dim m As SldWorks.ModelDoc2
Set m = [Link]([Link]( _
swUserPreferenceStringValue_e.swDefaultTemplatePart), 0, 0, 0)
If m Is Nothing Then [Link] vbObjectError + 101, , "Cannot create Part.
Check default part template."
[Link] _
swUserPreferenceIntegerValue_e.swUnitsLinear, _
swUserPreferenceOption_e.swDetailingNoOptionSpecified, swMM
Set NewPartDoc = m
End Function
' T?o Assembly an toàn cho SW2024 – không dùng GetOpenFileName
Private Function NewAsmDoc() As SldWorks.ModelDoc2
Dim tpl As String, m As SldWorks.ModelDoc2
Dim fso As Object: Set fso = CreateObject("[Link]")
' 1) L?y template Assembly m?c đ?nh t? System Options
tpl = [Link]( _
swUserPreferenceStringValue_e.swDefaultTemplateAssembly)
' 2) N?u r?ng ho?c file không t?n t?i ? th? các đư?ng d?n ph? bi?n
If Len(tpl) = 0 Or Not [Link](tpl) Then
Dim candidates As Variant, i As Long
candidates = Array( _
"C:\ProgramData\SOLIDWORKS\SOLIDWORKS 2024\templates\
[Link]", _
"C:\ProgramData\SolidWorks\SolidWorks 2024\templates\
[Link]", _
"C:\ProgramData\SOLIDWORKS\SOLIDWORKS 2024\lang\english\
[Link]" _
)
For i = LBound(candidates) To UBound(candidates)
If [Link](candidates(i)) Then
tpl = candidates(i)
Exit For
End If
Next i
End If
' 3) V?n chưa có ? h?i ngư?i dùng nh?p đư?ng d?n .ASMDOT
If Len(tpl) = 0 Or Not [Link](tpl) Then
tpl = InputBox( _
"Không t?m đư?c Assembly template (.asmdot)." & vbCrLf & _
"Nh?p đư?ng d?n đ?y đ? t?i file .asmdot (ví d?:" & vbCrLf & _
"C:\ProgramData\SOLIDWORKS\SOLIDWORKS 2024\templates\
[Link])", _
"Ch?n Template Assembly")
End If
If Len(tpl) = 0 Or Not [Link](tpl) Then
[Link] vbObjectError + 204, , _
"Chưa thi?t l?p đư?c Assembly template (.asmdot). " & _
"Vào Tools > Options > System Options > Default Templates/File
Locations đ? ki?m tra."
End If
' 4) T?o Assembly t? template đ? xác đ?nh
Set m = [Link](tpl, 0, 0, 0)
If m Is Nothing Then [Link] vbObjectError + 205, , "Không t?o đư?c
Assembly t? template: " & tpl
' Đ?t đơn v? mm
[Link] _
swUserPreferenceIntegerValue_e.swUnitsLinear, _
swUserPreferenceOption_e.swDetailingNoOptionSpecified, swMM
' Xác nh?n đúng lo?i Assembly
If [Link] <> swDocASSEMBLY Then _
[Link] vbObjectError + 206, , "Template không ph?i Assembly: " & tpl
Set NewAsmDoc = m
End Function
Private Sub SaveClose(m As SldWorks.ModelDoc2, ByVal path As String)
Dim errs As Long, warns As Long
m.SaveAs4 path, swSaveAsCurrentVersion, swSaveAsOptions_Silent, errs,
warns
[Link] [Link]
End Sub
' ---------------- Involute tooth sketch (2D) ----------------
Private Sub SketchInvoluteTooth(m As SldWorks.ModelDoc2, ByVal rb As Double,
_
ByVal ad As Double, ByVal td As Double, _
ByVal thk As Double, ByVal rotDeg As Double)
Dim sk As [Link]: Set sk = [Link]
Dim i As Integer, N As Integer: N = 28
Dim t As Double, tmax As Double, dt As Double
Dim x0 As Double, y0 As Double, x1 As Double, y1 As Double
Dim pitchR As Double, halfThkAngle As Double
Dim tr As [Link]: Set tr = [Link]
Dim data(15) As Double, ang As Double, c As Double, s As Double
pitchR = (ad + td) / 2#: halfThkAngle = thk / (2# * pitchR)
tmax = Sqr((ad / rb) ^ 2 - 1#): dt = tmax / N
[Link] True
' --- v? involute n?a bên ---
x0 = rb / 1000#: y0 = 0#
Dim seg As [Link]
' Dim segs() As [Link]: ReDim segs(1 To N)
Dim segs As Variant: ReDim segs(1 To N) ' << dùng Variant đ? tránh type
mismatch
' centerline đ? mirror
Dim cln As [Link]
Set cln = [Link](0#, 0#, 0#, 0.01, 0#, 0#)
For i = 1 To N
t = i * dt
x1 = rb * (Cos(t) + t * Sin(t)) / 1000#
y1 = rb * (Sin(t) - t * Cos(t)) / 1000#
Set seg = [Link](x0, y0, 0#, x1, y1, 0#)
Set segs(i) = seg
x0 = x1: y0 = y1
Next i
' --- ch?n các segment + centerline r?i mirror ---
m.ClearSelection2 True
For i = 1 To N
segs(i).Select4 True, 0
Next i
cln.Select4 True, 0
[Link] ' << đúng API SW2024
' --- d?ch 2 n?a involute đ? có b? dày răng t?i v?ng chia ---
ang = halfThkAngle: c = Cos(ang): s = Sin(ang)
data(0) = c: data(1) = -s: data(2) = 0#: data(3) = 0#
data(4) = s: data(5) = c: data(6) = 0#: data(7) = 0#
data(8) = 0#: data(9) = 0#: data(10) = 1#: data(11) = 0#
data(12) = 0#: data(13) = 0#: data(14) = 0#: data(15) = 1#
[Link] [Link](data)
' --- v?ng g?c & v?ng đ?nh đ? khép biên ---
[Link] 0#, 0#, 0#, td / 1000#
[Link] 0#, 0#, 0#, ad / 1000#
' --- quay toàn b? profile n?u c?n ---
If rotDeg <> 0# Then
ang = DegToRad(rotDeg): c = Cos(ang): s = Sin(ang)
data(0) = c: data(1) = -s: data(4) = s: data(5) = c
[Link] [Link](data)
End If
[Link] True
End Sub
' ---------------- Ring (răng th?ng) ----------------
Private Function BuildRing(ByVal outPath As String) As String
Dim m As SldWorks.ModelDoc2: Set m = NewPartDoc()
' Phôi v?ng
[Link] True
[Link] 0#, 0#, 0#, MmToM(RING_OD / 2#)
[Link] True
[Link].FeatureExtrusion2 True, False, False, 0, 0,
MmToM(FACE_WIDTH), 0#, False, False, False, False, 0#, 0#, False, False, False,
False, True, True, True, 0#, 0#, False
' Thông s? răng
Dim m_n As Double: m_n = R_MODULE_N
Dim z As Long: z = R_TEETH
Dim alpha As Double: alpha = DegToRad(R_PRESSURE)
Dim d As Double: d = m_n * z
Dim rb As Double: rb = (d / 2#) * Cos(alpha)
Dim add As Double: add = d / 2# + m_n
Dim ded As Double: ded = d / 2# - 1.25 * m_n
Dim s As Double: s = 1.5708 * m_n
' Sketch 1 răng + c?t xuyên su?t
[Link].SelectByID2 "Front Plane", "PLANE", 0, 0, 0, False, 0, Nothing, 0
[Link] True
SketchInvoluteTooth m, rb, add, ded, s, 0#
[Link] True
[Link].FeatureCut3 True, False, False, _
0, 0, MmToM(FACE_WIDTH), MmToM(FACE_WIDTH), _
False, False, False, False, 0#, 0#, _
False, False, False, False, _
False, True, True, True, True, False, 0#, 0#, False
' Pattern theo s? răng
[Link].SelectByID2 "Cut-Extrude1", "BODYFEATURE", 0#, 0#, 0#, False,
0, Nothing, 0
[Link].FeatureCircularPattern3 z, 6.28318530718, False, "NULL",
False, True
SaveClose m, outPath
BuildRing = outPath
End Function
' ---------------- Pinion (răng th?ng) ----------------
Private Function BuildPinion(ByVal outPath As String) As String
Dim m As SldWorks.ModelDoc2: Set m = NewPartDoc()
' Phôi tr?
[Link] True
Dim d As Double: d = R_MODULE_N * P_TEETH
[Link] 0#, 0#, 0#, MmToM(d / 2#)
[Link] True
[Link].FeatureExtrusion2 True, False, False, 0, 0,
MmToM(FACE_WIDTH), 0#, False, False, False, False, 0#, 0#, False, False, False,
False, True, True, True, 0#, 0#, False
' Răng involute + c?t xuyên su?t
Dim alpha As Double: alpha = DegToRad(R_PRESSURE)
Dim rb As Double: rb = (d / 2#) * Cos(alpha)
Dim add As Double: add = d / 2# + R_MODULE_N
Dim ded As Double: ded = d / 2# - 1.25 * R_MODULE_N
Dim s As Double: s = 1.5708 * R_MODULE_N
[Link].SelectByID2 "Front Plane", "PLANE", 0, 0, 0, False, 0, Nothing, 0
[Link] True
SketchInvoluteTooth m, rb, add, ded, s, 0#
[Link] True
[Link].FeatureCut3 True, False, False, _
0, 0, MmToM(FACE_WIDTH), MmToM(FACE_WIDTH), _
False, False, False, False, 0#, 0#, _
False, False, False, False, _
False, True, True, True, True, False, 0#, 0#, False
[Link].SelectByID2 "Cut-Extrude1", "BODYFEATURE", 0#, 0#, 0#, False,
0, Nothing, 0
[Link].FeatureCircularPattern3 P_TEETH, 6.28318530718, False,
"NULL", False, True
' Thêm tr?c
[Link] True
[Link] 0#, 0#, 0#, MmToM(10#)
[Link] True
[Link].FeatureExtrusion2 True, False, False, 0, 0, MmToM(180#),
0#, False, False, False, False, 0#, 0#, False, False, False, False, True, True, True,
0#, 0#, False
SaveClose m, outPath
BuildPinion = outPath
End Function
' ---------------- Bevel gears (gi?n lư?c) ----------------
Private Function BuildBevel(ByVal outPath As String, ByVal z As Long, ByVal modn
As Double, ByVal faceW As Double, ByVal pcd As Double) As String
Dim m As SldWorks.ModelDoc2: Set m = NewPartDoc()
' T?o phôi vát (revolve boss)
[Link] True
[Link] 0#, 0#, 0#, MmToM(pcd / 2#), 0#, 0#
[Link] MmToM(pcd / 2#), 0#, 0#, MmToM(pcd / 2# -
faceW * 0.3), MmToM(faceW), 0#
[Link] MmToM(pcd / 2# - faceW * 0.3), MmToM(faceW),
0#, 0#, MmToM(faceW), 0#
[Link] 0#, MmToM(faceW), 0#, 0#, 0#, 0#
' Tr?c quay (centerline) đ? InsertRevolvedBoss2 nh?n tr?c
[Link] 0#, 0#, 0#, 0#, MmToM(faceW * 1.2), 0#
[Link] True
[Link].InsertRevolvedBoss2 _
True, True, False, False, False, False, _
0, 0, 6.28318530718, 0#, _
False, False, 0#, 0#, 0#, _
True, True, True
' C?t răng đơn gi?n r?i pattern
Dim d As Double: d = modn * z
Dim s As Double: s = 1.5708 * modn
[Link] True
[Link] MmToM(d / 2#), 0#, 0#, MmToM(d /
2# + s / 2#), MmToM(faceW / 3#), 0#
[Link] True
[Link].FeatureCut3 True, False, False, 0, 0, MmToM(faceW),
MmToM(faceW), False, False, False, False, 0#, 0#, False, False, False, False, False,
True, True, True, True, False, 0#, 0#, False
[Link].SelectByID2 "Cut-Extrude1", "BODYFEATURE", 0#, 0#, 0#, False,
0, Nothing, 0
[Link].FeatureCircularPattern3 z, 6.28318530718, False, "NULL",
False, True
SaveClose m, outPath
BuildBevel = outPath
End Function
Private Function BuildAxle(ByVal outPath As String) As String
Dim m As SldWorks.ModelDoc2: Set m = NewPartDoc()
[Link] True
[Link] 0#, 0#, 0#, MmToM(AXLE_STUB_D /
2#)
[Link] True
[Link].FeatureExtrusion2 True, False, False, 0, 0,
MmToM(AXLE_STUB_LEN), 0#, False, False, False, False, 0#, 0#, False, False,
False, False, True, True, True, 0#, 0#, False
SaveClose m, outPath
BuildAxle = outPath
End Function
Private Function BuildCase(ByVal outPath As String) As String
Dim m As SldWorks.ModelDoc2: Set m = NewPartDoc()
' Khoét r?ng thay cho Shell: t?o l? trong v?i b? dày CASE_WALL
[Link] True
[Link] 0#, 0#, 0#, MmToM(CASE_OD / 2# -
CASE_WALL)
[Link] True
[Link].FeatureCut3 True, False, False, _
0, 0, MmToM(CASE_LEN), MmToM(CASE_LEN), _
False, False, False, False, 0#, 0#, _
False, False, False, False, _
False, True, True, True, True, False, 0#, 0#, False
SaveClose m, outPath
BuildCase = outPath
End Function
' ---------------- Assembly + Exploded + Drawing ----------------
Private Sub MateToOrigin(m As SldWorks.ModelDoc2, comp As
SldWorks.Component2)
Dim asm As [Link]: Set asm = m
[Link].SelectByID2 "Front Plane", "PLANE", 0, 0, 0, False, 1, Nothing, 0
[Link].SelectByID2 "Front Plane@" & comp.Name2 & "-1@" &
[Link], "PLANE", 0, 0, 0, True, 2, Nothing, 0
asm.AddMate5 swMateCOINCIDENT, swMateAlignALIGNED, True, 0, 0, 0, 0, 0,
0, 0, 0, False, False, 0, 0
[Link].SelectByID2 "Top Plane", "PLANE", 0, 0, 0, False, 1, Nothing, 0
[Link].SelectByID2 "Top Plane@" & comp.Name2 & "-1@" & [Link],
"PLANE", 0, 0, 0, True, 2, Nothing, 0
asm.AddMate5 swMateCOINCIDENT, swMateAlignALIGNED, True, 0, 0, 0, 0, 0,
0, 0, 0, False, False, 0, 0
[Link].SelectByID2 "Right Plane", "PLANE", 0, 0, 0, False, 1, Nothing, 0
[Link].SelectByID2 "Right Plane@" & comp.Name2 & "-1@" &
[Link], "PLANE", 0, 0, 0, True, 2, Nothing, 0
asm.AddMate5 swMateCOINCIDENT, swMateAlignALIGNED, True, 0, 0, 0, 0, 0,
0, 0, 0, False, False, 0, 0
End Sub
Private Sub CreateExploded(m As SldWorks.ModelDoc2)
Dim asm As [Link]: Set asm = m
[Link]
asm.AddExplodeStep3 0, 0, MmToM(50#), 0, 0, 0, 0, 0
asm.AddExplodeStep3 MmToM(AXLE_TUBE_OFFSET), 0, 0, 0, 0, 0, 0, 0
asm.AddExplodeStep3 -MmToM(AXLE_TUBE_OFFSET), 0, 0, 0, 0, 0, 0, 0
[Link] swForceRebuildAll
End Sub
Private Sub BuildAssemblyAndDrawing(outDir As String, ByRef asmPath As
String, ByRef drwPath As String)
Dim ringP As String, pinionP As String, caseP As String, sideL As String, sideR
As String, planetP As String, axleP As String
ringP = outDir & "\[Link]"
pinionP = outDir & "\[Link]"
caseP = outDir & "\[Link]"
sideL = outDir & "\SideGear_L.SLDPRT"
sideR = outDir & "\SideGear_R.SLDPRT"
planetP = outDir & "\[Link]"
axleP = outDir & "\[Link]"
BuildCase caseP: BuildRing ringP: BuildPinion pinionP
BuildBevel sideL, SIDE_Z, SIDE_MOD, SIDE_FACE, SIDE_PCD
BuildBevel sideR, SIDE_Z, SIDE_MOD, SIDE_FACE, SIDE_PCD
BuildBevel planetP, PLANET_Z, SIDE_MOD, SIDE_FACE * 0.7, SIDE_PCD * 0.6
BuildAxle axleP
Dim m As SldWorks.ModelDoc2
Set m = NewAsmDoc()
Dim asm As [Link]: Set asm = m
Dim cCase As SldWorks.Component2, cRing As SldWorks.Component2, cPin As
SldWorks.Component2
Dim cSL As SldWorks.Component2, cSR As SldWorks.Component2, cPL1 As
SldWorks.Component2, cPL2 As SldWorks.Component2, cPL3 As
SldWorks.Component2
Dim cAxL As SldWorks.Component2, cAxR As SldWorks.Component2
Set cCase = asm.AddComponent5(caseP, 0, "", False, "", 0, 0, 0)
Set cRing = asm.AddComponent5(ringP, 0, "", False, "", 0, 0, 0)
Set cPin = asm.AddComponent5(pinionP, 0, "", False, "", 0,
MmToM(PINION_OFFSET), 0)
Set cSL = asm.AddComponent5(sideL, 0, "", False, "", MmToM(SIDE_OFFSET),
0, 0)
Set cSR = asm.AddComponent5(sideR, 0, "", False, "", -MmToM(SIDE_OFFSET),
0, 0)
Set cPL1 = asm.AddComponent5(planetP, 0, "", False, "", 0, 0, 0)
Set cPL2 = asm.AddComponent5(planetP, 0, "", False, "", 0, 0, MmToM(60#))
Set cPL3 = asm.AddComponent5(planetP, 0, "", False, "", 0, 0, -MmToM(60#))
Set cAxL = asm.AddComponent5(axleP, 0, "", False, "",
MmToM(AXLE_TUBE_OFFSET), 0, 0)
Set cAxR = asm.AddComponent5(axleP, 0, "", False, "", -
MmToM(AXLE_TUBE_OFFSET), 0, 0)
MateToOrigin m, cCase: MateToOrigin m, cRing: MateToOrigin m, cPin
MateToOrigin m, cSL: MateToOrigin m, cSR
MateToOrigin m, cPL1: MateToOrigin m, cPL2: MateToOrigin m, cPL3
MateToOrigin m, cAxL: MateToOrigin m, cAxR
CreateExploded m
Dim errs As Long, warns As Long
asmPath = outDir & "\ViSai_Diff_Detailed.SLDASM"
m.SaveAs4 asmPath, swSaveAsCurrentVersion, swSaveAsOptions_Silent, errs,
warns
Dim drw As SldWorks.ModelDoc2
drwPath = outDir & "\ViSai_Diff_Detailed.SLDDRW"
Set drw = [Link]([Link]( _
swUserPreferenceStringValue_e.swDefaultTemplateDrawing), 0, 0, 0)
drw.Create3rdAngleViews2 asmPath
drw.ViewZoomtofit2
[Link] 0.2, 0.25, 3, 2, 0, _
"Item,Part,Qty" & vbCr & _
"1,DiffCase,1" & vbCr & _
"2,RingGear,1" & vbCr & _
"3,Pinion,1" & vbCr & _
"4,SideGear L/R,2" & vbCr & _
"5,PlanetGear,3" & vbCr & _
"6,AxleStub,2"
drw.SaveAs4 drwPath, swSaveAsCurrentVersion, swSaveAsOptions_Silent, errs,
warns
If EXPORT_STEP Then
Dim stepPath As String: stepPath = outDir & "\ViSai_Diff_Detailed.step"
m = swApp.ActivateDoc3(asmPath, True, 0, errs)
[Link] stepPath, 0, 0, Nothing, errs, warns
End If
End Sub
Sub main()
EXPORT_STEP = False ' True n?u mu?n auto xu?t STEP
Set swApp = [Link]
Dim outDir As String: outDir = DefaultOutDir()
Dim asmPath As String, drwPath As String
BuildAssemblyAndDrawing outDir, asmPath, drwPath
MsgBox "Done." & vbCrLf & asmPath & vbCrLf & drwPath, vbInformation,
"Differential Detailed"
End Sub