Lesson 5.1 - drawer

Files

Code

Modules: Module5_1

Option Explicit
    
Public Const strCompPath As String = "C:\Users\Keith\Desktop\drawer front\knob.SLDPRT"
Public swApp As SldWorks.SldWorks
Public swModel As SldWorks.ModelDoc2
Public swAssy As SldWorks.AssemblyDoc
Public swSelMgr As SldWorks.SelectionMgr
Public swFace As SldWorks.Face2
Public swDrawer As SldWorks.Component2
Public swKnob As SldWorks.Component2
Public swKnobFace As SldWorks.Entity
Public swDrawerFace As SldWorks.Entity
Public swDrawerEdge As SldWorks.Entity
Public collDrawerEdge As Collection
Public collKnobFace As Collection
Public j As Integer
    
Sub main()
    Set swApp = Application.SldWorks
    Set swModel = swApp.ActiveDoc
    Set swAssy = swModel
    Set swSelMgr = swModel.SelectionManager
    Set collDrawerEdge = New Collection
    Set collKnobFace = New Collection
    
    If swSelMgr.GetSelectedObjectType3(1, -1) <> swSelFACES Then
        MsgBox "Please select a face."
        End
    End If
    
    'Get the drawer face
    Set swFace = swSelMgr.GetSelectedObject6(1, -1)
    Set swDrawerFace = swFace
    Set swDrawerFace = swDrawerFace.GetSafeEntity
    
    'Get the full circle edge(s) from drawer face
    Call GetDrawerEdge
    
    For j = 1 To collDrawerEdge.Count
        'Add the component
        Call AddComps
        
        'Get the cylindrical face(s) from knob(s)
        Call GetKnobFace
    
        'Add mates
        Call AddMates
    Next j
    
    swModel.ClearSelection2 True
    swModel.ForceRebuild3 False
End Sub

Modules: mAddComps

Sub AddComps()
    swApp.DocumentVisible False, swDocPART
    swApp.OpenDoc6 strCompPath, swDocPART, 0, "", Empty, Empty
    Set swKnob = swAssy.AddComponent4(strCompPath, "", 0, 0, 0)
    swApp.DocumentVisible True, swDocPART
End Sub

Modules: mAddMates

Sub AddMates()
    'Add coincident mate
    swDrawerFace.Select4 False, Nothing
    swModel.Extension.SelectByID2 "Top Plane@" & swKnob.Name2 & "@drawer front", "PLANE", _
        0, 0, 0, True, 0, Nothing, 0
    swAssy.AddMate3 swMateCOINCIDENT, swMateAlignALIGNED, False, Empty, Empty, Empty, _
        Empty, Empty, Empty, Empty, Empty, False, Empty
    
    'Add concentric mate
    collKnobFace.Item(j).Select4 False, Nothing
    collDrawerEdge.Item(j).Select4 True, Nothing
    swAssy.AddMate3 swMateCONCENTRIC, swMateAlignANTI_ALIGNED, False, Empty, Empty, Empty, _
        Empty, Empty, Empty, Empty, Empty, False, Empty
End Sub

Modules: mGetDrawerEdge

Sub GetDrawerEdge()
    Dim vEdges As Variant
    Dim swEdge As SldWorks.Edge
    Dim swCurve As SldWorks.Curve
    Dim swVertex As SldWorks.Vertex
    Dim i As Integer
    
    Set swFace = swDrawerFace
    vEdges = swFace.GetEdges
    For i = 0 To UBound(vEdges)
        Set swEdge = vEdges(i)
        Set swCurve = swEdge.GetCurve
        If swCurve.Identity = 3002 Then
            Set swVertex = swEdge.GetStartVertex
            If swVertex Is Nothing Then
                Set swDrawerEdge = swEdge
                Set swDrawerEdge = swDrawerEdge.GetSafeEntity
                collDrawerEdge.Add swDrawerEdge
            End If
        End If
    Next i
    If swDrawerEdge Is Nothing Then End
End Sub

Modules: mGetKnobFace

Sub GetKnobFace()
    Dim vFaces As Variant
    Dim vBodies As Variant
    Dim swBody As SldWorks.Body2
    Dim swSurf As SldWorks.Surface
    Dim dblArea As Double
    Dim i As Integer
    
    vBodies = swKnob.GetBodies3(swSolidBody, Empty)
    Set swBody = vBodies(0)
    vFaces = swBody.GetFaces
    For i = 0 To UBound(vFaces)
        Set swFace = vFaces(i)
        Set swSurf = swFace.GetSurface
        If swSurf.IsCylinder Then
            Set swKnobFace = swFace
            collKnobFace.Add swKnobFace
            Exit For
        End If
    Next i
End Sub