Lesson 4.2c - create plate with traversal

Files

Lesson 4.2c - create plate with traversal Associated model(s)

Code

Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Dim swSketchMgr As SldWorks.SketchManager
Dim swFeatMgr As SldWorks.FeatureManager
Dim swFeat As SldWorks.Feature
Dim j As Integer
    
Sub main()
    Set swApp = Application.SldWorks
    Set swModel = swApp.ActiveDoc
    Set swSketchMgr = swModel.SketchManager
    Set swFeatMgr = swModel.FeatureManager
    
    'create plate sketch profile
    '########## REPLACES SELECTBYID2 ##########
    Set swFeat = swModel.FirstFeature
    Do While Not swFeat Is Nothing
        If swFeat.GetTypeName = "RefPlane" Then Exit Do
        Set swFeat = swFeat.GetNextFeature
    Loop
    swFeat.Select2 False, 0
    '##########################################
    swSketchMgr.InsertSketch True
    swSketchMgr.CreateCircleByRadius 0, 0, 0, 0.05
    swModel.Extension.SelectByID2 "", "EXTSKETCHPOINT", 0, 0, 0, False, 6, Nothing, 0
    swSketchMgr.FullyDefineSketch True, True, 1023, True, 1, Nothing, 1, Nothing, 0, 0
    
    'create mid-plane base extrusion
    swFeatMgr.FeatureExtrusion2 True, False, False, 6, 0, 0.01, 0, False, False, False, _
        False, 0, 0, False, False, False, False, True, True, True, 0, 0, False
        
    'create extrude cut profile
    '########## REPLACES SELECTBYID2 ##########
    Set swFeat = swModel.FirstFeature
    Do While Not swFeat Is Nothing
        If swFeat.GetTypeName = "RefPlane" Then Exit Do
        Set swFeat = swFeat.GetNextFeature
    Loop
    swFeat.Select2 False, 0
    '##########################################
    swSketchMgr.InsertSketch True
    swSketchMgr.CreateCircleByRadius -0.04, 0, 0, 0.004
    swModel.Extension.SelectByID2 "", "EXTSKETCHPOINT", 0, 0, 0, False, 6, Nothing, 0
    swSketchMgr.FullyDefineSketch True, True, 1023, True, 1, Nothing, 1, Nothing, 0, 0
    
    'create bi-directional cut extrude
    swFeatMgr.FeatureCut3 False, False, False, 1, 1, 0.01, 0.01, False, False, False, False, _
        0, 0, False, False, False, False, False, True, True, True, True, False, 0, 0, False
    
    'create an axis
    '########## REPLACES SELECTBYID2 ##########
    Set swFeat = swModel.FirstFeature
    j = 0
    Do While Not swFeat Is Nothing
        If swFeat.GetTypeName = "RefPlane" Then
            If j = 1 Then Exit Do                   'the 2nd default plane
            j = j + 1
        End If
        Set swFeat = swFeat.GetNextFeature
    Loop
    swFeat.Select2 False, 0
    '##########################################
    '########## REPLACES SELECTBYID2 ##########
    Set swFeat = swModel.FirstFeature
    j = 0
    Do While Not swFeat Is Nothing
        If swFeat.GetTypeName = "RefPlane" Then
            If j = 2 Then Exit Do                   'the 3rd default plane
            j = j + 1
        End If
        Set swFeat = swFeat.GetNextFeature
    Loop
    swFeat.Select2 True, 0
    '##########################################
    swModel.InsertAxis2 True
    
    'create a circular pattern of extrude cut
    '########## REPLACES SELECTBYID2 ##########
    Set swFeat = swModel.FirstFeature
    Do While Not swFeat Is Nothing
        If swFeat.GetTypeName = "RefAxis" Then Exit Do
        Set swFeat = swFeat.GetNextFeature
    Loop
    swFeat.Select2 False, 1
    '##########################################
    '########## REPLACES SELECTBYID2 ##########
    Set swFeat = swModel.FirstFeature
    Do While Not swFeat Is Nothing
        If swFeat.GetTypeName = "Cut" Then Exit Do
        Set swFeat = swFeat.GetNextFeature
    Loop
    swFeat.Select2 True, 4
    '##########################################
    swFeatMgr.FeatureCircularPattern2 10, 2 * 4 * Atn(1) / 10, False, "", False
    
    'create a simple fillet on outside edges
    Dim swPart As SldWorks.PartDoc
    Dim vBodies As Variant
    Dim swBody As SldWorks.Body2
    Dim vFaces As Variant
    Dim swFace As SldWorks.Face2
    Dim swFinalFace As SldWorks.Face2
    Dim swSurf As SldWorks.Surface
    Dim swEnt As SldWorks.Entity
    Dim i As Integer
    Dim dblArea As Double
    
    dblArea = 0
    Set swPart = swModel
    vBodies = swPart.GetBodies2(swSolidBody, False)
    Set swBody = vBodies(0) 'assumes only one solid body in part
    vFaces = swBody.GetFaces
    For i = 0 To UBound(vFaces)
        Set swFace = vFaces(i)
        Set swSurf = swFace.GetSurface
        If swSurf.IsCylinder Then
            If swFace.GetArea > dblArea Then
                dblArea = swFace.GetArea
                Set swFinalFace = swFace
            End If
        End If
    Next i
    Set swEnt = swFinalFace
    swEnt.Select4 False, Nothing
    swFeatMgr.FeatureFillet 2, 0.001, 0, 0, Empty, Empty, Empty
    
    'change material
    swPart.SetMaterialPropertyName2 "", "", "Plain Carbon Steel"
End Sub