Lesson 5.2 code

Files

Lesson 5.2 code

Code

Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Dim swAssy As SldWorks.AssemblyDoc
Dim swSelMgr As SldWorks.SelectionMgr
Dim swComp As SldWorks.Component2
Dim swFeat As SldWorks.Feature
Dim strCompName As String
    
Sub CreateSolid()
    'Get bounding box of remaining visible components
    Dim vBox As Variant
    vBox = swAssy.GetBox(0)
    
    'Select front plane for inserting new part.
    Dim swRefPlane As SldWorks.RefPlane
    Set swFeat = swModel.FirstFeature
    Do While Not swFeat Is Nothing
        If swFeat.GetTypeName = "RefPlane" Then
            Set swRefPlane = swFeat.GetSpecificFeature2
            Exit Do
        End If
        Set swFeat = swFeat.GetNextFeature
    Loop
    
    'Get the root component name
    Dim swConfigMgr As SldWorks.ConfigurationManager
    Dim swConfig As SldWorks.Configuration
    Dim strRootCompName As String
    Set swConfigMgr = swModel.ConfigurationManager
    Set swConfig = swConfigMgr.ActiveConfiguration
    Set swComp = swConfig.GetRootComponent3(False)
    strRootCompName = swComp.Name2
    
    'Insert new virtual part
    swAssy.InsertNewVirtualPart swRefPlane, swComp
    strCompName = swComp.Name2
    
    'Select Sketch1 of new virtual part and open
    swModel.Extension.SelectByID2 "Sketch1@" & strCompName & "@" & _
        strRootCompName, "SKETCH", 0, 0, 0, False, 0, Nothing, 0
    Dim swSketchMgr As SldWorks.SketchManager
    Set swSketchMgr = swModel.SketchManager
    swSketchMgr.InsertSketch True
    swModel.SetAddToDB True
    
    'Draw bounding box profile (UL-->UR; UR-->BR; BR-->BL; BL-->UL)
    swSketchMgr.CreateLine vBox(0), vBox(4), 0, vBox(3), vBox(4), 0
    swSketchMgr.CreateLine vBox(3), vBox(4), 0, vBox(3), vBox(1), 0
    swSketchMgr.CreateLine vBox(3), vBox(1), 0, vBox(0), vBox(1), 0
    swSketchMgr.CreateLine vBox(0), vBox(1), 0, vBox(0), vBox(4), 0
    
    'Get the depth for use in the extrusion
    Dim dblDepth As Double
    dblDepth = vBox(5) - vBox(2)
    
    'Insert base extrude
    swModel.FeatureManager.FeatureExtrusion2 True, False, False, 0, 0, _
        dblDepth, 0, False, False, True, True, 0, 0, False, False, _
        False, False, False, False, True, swStartOffset, vBox(2), False
    
    'Exit sketch and exit edit part mode
    swSketchMgr.InsertSketch True
    swAssy.EditAssembly
    swModel.SetAddToDB False
    swModel.ClearSelection2 True
End Sub
    
Sub main()
    Set swApp = Application.SldWorks
    Set swModel = swApp.ActiveDoc
    Set swAssy = swModel
    Set swSelMgr = swModel.SelectionManager
    
    'Re-size swSelComp array
    Dim swSelComp() As SldWorks.Component2
    If swSelMgr.GetSelectedObjectCount2(-1) <> 0 Then
        ReDim swSelComp(swSelMgr.GetSelectedObjectCount2(-1) - 1) _
            As SldWorks.Component2
    Else
        End
    End If
    
    'Get the selected components
    Dim i As Integer
    For i = 1 To swSelMgr.GetSelectedObjectCount2(-1)
        If swSelMgr.GetSelectedObjectType3(i, -1) = swSelCOMPONENTS Then
            Set swSelComp(i - 1) = swSelMgr.GetSelectedObject6(i, -1)
        ElseIf swSelMgr.GetSelectedObjectType3(i, -1) = swSelFACES Then
            Set swSelComp(i - 1) = swSelMgr.GetSelectedObjectsComponent3(i, -1)
        Else
            MsgBox "Please selected a component."
            End
        End If
    Next i
    
    'Hide all components
    swApp.SetUserPreferenceDoubleValue swViewTransitionHideShowComponent, 0
    Dim vComps As Variant
    vComps = swAssy.GetComponents(False)
    For i = 0 To UBound(vComps)
        Set swComp = vComps(i)
        swComp.Visible = False
    Next i
    
    'Show selected components
    For i = 0 To UBound(swSelComp)
        swSelComp(i).Visible = True
    Next i
    
    'Create new part that consumes the bounded area
    Call CreateSolid
    
    'Delete last InPlace mate to avoid assy structure editing warning
    Dim swSubFeat As SldWorks.Feature
    Dim swInPlaceMateFeat As SldWorks.Feature
    swModel.Extension.SelectByID2 "Mates", "MATEGROUPS", 0, 0, 0, _
        False, 0, Nothing, 0
    Set swFeat = swSelMgr.GetSelectedObject6(1, -1)
    Set swSubFeat = swFeat.GetFirstSubFeature
    While Not swSubFeat Is Nothing
        If InStr(1, swSubFeat.Name, "InPlace") <> 0 Then _
            Set swInPlaceMateFeat = swSubFeat
        Set swSubFeat = swSubFeat.GetNextSubFeature
    Wend
    swInPlaceMateFeat.Select2 False, 0
    swModel.EditDelete
    
    'Put new part in sub-assy
    Set swComp = swAssy.GetComponentByName(strCompName)
    swComp.Select4 False, Nothing, False
    swAssy.MakeAssemblyFromSelectedComponents Empty
    
    'Show all components
    For i = 0 To UBound(vComps)
        Set swComp = vComps(i)
        swComp.Visible = True
    Next i
    
    'Revert settings
    swApp.SetUserPreferenceDoubleValue swViewTransitionHideShowComponent, 1
End Sub