Macros

Dim swApp As SldWorks.SldWorks

Dim swModel As SldWorks.ModelDoc2

Dim swCustPropMgr As SldWorks.CustomPropertyManager

Dim names As Variant

Dim name As Variant

Dim textexp As String

Dim evalval As String

Dim PNVal, DescVal, RevVal, Filetype As String

Sub main()

Dim obj As New DataObject

Dim FileLoc As String

Set swApp = Application.SldWorks

Set swModel = swApp.ActiveDoc

Set swCustPropMgr = swModel.Extension.CustomPropertyManager("")

'This MACRO should open the folder that the current file is contained in as well as insert the folder name into the clipboard

If swApp.ActiveDoc Is Nothing Then

    MsgBox "Please open a file first."

    End

End If

FileLoc = Left(swModel.GetPathName, InStrRev(swModel.GetPathName, "\"))

On Error Resume Next

On Error GoTo 0

Call Shell("explorer.exe" & " " & Chr(34) & FileLoc & Chr(34), vbNormalFocus)

 obj.SetText FileLoc

 obj.PutInClipboard

End Sub

'REF https://help.solidworks.com/2017/english/api/sldworksapi/get_mates_example_vb.htm

'REF https://help.solidworks.com/2020/English/api/sldworksapi/Edit_Mate_Example_VB.htm

'REF https://help.solidworks.com/2020/English/api/sldworksapi/Create_Standard_Mates_Example_VB.htm

'NOTHING SELECTED - Select DWP

'ONE ITEM SELECTED - Parallel with Triggered DWP

'ONE ITEM SELECTED (AND ALREADY PARALLEL w/ DWP) - Coincident with Triggered DWP

'TWO ITEMS SELECTED - Triggered DWP's parallel

'TWO ITEMS SELECTED (AND ALREADY PARALLEL) - Triggered DWP's Coincident

Option Explicit

    Dim swApp                       As SldWorks.SldWorks

    Dim swModel                     As SldWorks.ModelDoc2

    Dim swAssy                      As SldWorks.AssemblyDoc

    Dim swEnt                       As SldWorks.Entity

    Dim swMate                      As SldWorks.Mate2

    Dim swMateEnt1                   As SldWorks.MateEntity2

    Dim swMateEnt2                  As SldWorks.MateEntity2

    Dim swSelMgr                    As SldWorks.SelectionMgr

    Dim swSelComp                   As SldWorks.Component2

    Dim swSelComp2                  As SldWorks.Component2

    Dim swCompModel                 As SldWorks.ModelDoc2

    Dim swCompModel2                As SldWorks.ModelDoc2

    Dim swMateFeature               As SldWorks.feature

    Dim swFeat                      As SldWorks.feature

    Dim bRet                        As Boolean

    Dim i                           As Integer

Sub Front()

    PlaneMate (1)

End Sub

Sub Top()

    PlaneMate (2)

End Sub

Sub Right()

    PlaneMate (3)

End Sub

Sub PlaneMate(iTrig As Integer) '1 - FRONT, 2 - TOP, 3 - RIGHT, 0 - ORIGIN

    Set swApp = Application.SldWorks

    Set swModel = swApp.ActiveDoc

    Set swSelMgr = swModel.SelectionManager

    If swModel.GetType = swDocASSEMBLY Then '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ASSEMBLY

        Set swAssy = swModel

        i = swSelMgr.GetSelectedObjectCount2(-1) 'Get number of selected items

        Select Case i   '~~~~~~~~~~~~~~~~BASED ON NUMBER OF SELECTED COMPONENTS

            Case 0 'Select

                SelTLAItem iTrig, swModel

                Exit Sub

            Case 1 'Mate w/ TLA DWP

                Set swSelComp = swSelMgr.GetSelectedObjectsComponent2(1) 'The selection contains at least one component

                If Not (swSelComp Is Nothing) Then  'The selection is NOT a component

                    Set swMate = GetLastMate(swSelComp)

                    bRet = TestMateTLA(swMate, swModel, iTrig, swSelComp, swMatePARALLEL)

                    If Not bRet Then

                        SelTLAItem iTrig, swModel

                        AddParallelMate swAssy

                        SelTLAItem iTrig, swModel, True

                    Else

                    'Test if mate is between selected entity and desired entity

                        bRet = TestMateTLA(swMate, swModel, iTrig, swSelComp, swMatePARALLEL)

                        If bRet Then

                            DelLastMate swModel, swMate

                            SelMateEntities swModel, swMate

                            SelTLAItem iTrig, swModel

                            AddCoincidentMate swAssy

                            swModel.ClearSelection2 (True)

                        End If

                    End If

                Else

                    SelTLAItem 4, swModel

                End If

            Case Else 'Mate each DWP

                Set swSelComp = swSelMgr.GetSelectedObjectsComponent2(1) 'The selection contains at least one component

                Set swMate = GetLastMate(swSelComp)

                Set swSelComp2 = swSelMgr.GetSelectedObjectsComponent2(2) 'The selection contains at least one component

                Set swMate = GetLastMate(swSelComp2)

                If Not (swSelComp Is Nothing) And Not (swSelComp2 Is Nothing) Then  'The selection is NOT a component

                    bRet = TestMateComp(swMate, swSelComp, iTrig, swSelComp2, swMatePARALLEL)

                    If Not bRet Then

                        swModel.ClearSelection2 (True)

                        SelCompItem iTrig, swSelComp

                        SelCompItem iTrig, swSelComp2

                        AddParallelMate swAssy

                    Else

                        'Test if mate is between selected entity and desired entity

'''                        bRet = TestMateComp(swMate, swSelComp, iTrig, swSelComp2, swMatePARALLEL)

'''                        If bRet Then

                            DelLastMate swModel, swMate

                            SelMateEntities swModel, swMate

''''                            SelCompItem iTrig, swSelComp

''''                            SelCompItem iTrig, swSelComp2

                            AddCoincidentMate swAssy

                            swModel.ClearSelection2 (True)

'''                        End If

                    End If

                End If

        End Select

'        If i <> 0 Then 'Something is selected

'            Set swSelComp = swSelMgr.GetSelectedObjectsComponent2(1) 'The selection contains at least one component

'            If Not (swSelComp Is Nothing) Then  'The selection is NOT a component

'                swModel.ClearSelection2 True

'                SelCompItem iTrig, swSelComp

'            End If

'        End If

'            GetMates swAssy, swSelComp

    ElseIf swModel.GetType = swDocPART Then '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~PART

        SelTLAItem iTrig, swModel

    End If

End Sub

Sub SelCompItem(iTrig As Integer, comp As SldWorks.Component2)

    Dim strName As String

        Select Case iTrig

            Case 4

                SelCompOrigin comp 'bRet = comp.Extension.SelectByID2("Origin", "EXTSKETCHPOINT", 0, 0, 0, False, 0, Nothing, swSelectOptionDefault)

                Exit Sub

            Case 1

                strName = "Front Plane"

            Case 2

              strName = "Top Plane"

            Case 3

              strName = "Right Plane"

        End Select

        SelCompPlane comp, strName

        'bRet = comp.GetModelDoc2.SelectByID(strName, "PLANE", 0, 0, 0)

End Sub

Function SelCompOrigin(comp As SldWorks.Component2)

    Set swFeat = comp.FirstFeature

    Do While Not swFeat Is Nothing

        If "OriginProfileFeature" = swFeat.GetTypeName Then

            bRet = swFeat.Select2(True, 0)

            Exit Do

        End If

        Set swFeat = swFeat.GetNextFeature

    Loop

End Function

Function SelCompPlane(comp As SldWorks.Component2, str As String)

    Dim arrFeat() As Variant

    Dim intPlane As Integer

    Dim intFound As Integer

    intPlane = Switch(str = "Front Plane", 1, str = "Top Plane", 2, str = "Right Plane", 3)

    Set swFeat = comp.FirstFeature

    Do While Not swFeat Is Nothing

        If "RefPlane" = swFeat.GetTypeName Then

            If swFeat.Name = str Then

                bRet = swFeat.Select2(True, 0)

                Exit Do

            ElseIf intPlane = intFound Then

                bRet = swFeat.Select2(True, 0)                'Primarily used for French Planes

            End If

             intFound = intFound + 1

        End If

        Set swFeat = swFeat.GetNextFeature

    Loop

End Function

Sub SelTLAItem(iTrig As Integer, model As SldWorks.ModelDoc2, Optional DeSel As Boolean)

    Dim strName As String

        Select Case iTrig

            Case 4

                SelTLAOrigin model 'bRet = comp.Extension.SelectByID2("Origin", "EXTSKETCHPOINT", 0, 0, 0, False, 0, Nothing, swSelectOptionDefault)

                Exit Sub

            Case 1

                strName = "Front Plane"

            Case 2

              strName = "Top Plane"

            Case 3

              strName = "Right Plane"

        End Select

        SelTLAPlane model, strName, DeSel

End Sub

Function SelTLAOrigin(model As SldWorks.ModelDoc2)

    Set swFeat = model.FirstFeature

    Do While Not swFeat Is Nothing

        If "OriginProfileFeature" = swFeat.GetTypeName Then

            bRet = swFeat.Select2(False, 0)

            Exit Do

        End If

        Set swFeat = swFeat.GetNextFeature

    Loop

End Function

Function SelTLAPlane(model As SldWorks.ModelDoc2, str As String, Optional DeSel As Boolean)

    Dim arrFeat() As SldWorks.feature

    ReDim arrFeat(0)

    Dim intPlane As Integer

    Dim intFound As Integer

    intPlane = Switch(str = "Front Plane", 1, str = "Top Plane", 2, str = "Right Plane", 3)

    Set swFeat = model.FirstFeature

    Do While Not swFeat Is Nothing

        If "RefPlane" = swFeat.GetTypeName Then

            Set arrFeat(UBound(arrFeat)) = swFeat

            ReDim Preserve arrFeat(UBound(arrFeat) + 1)

''''            If swFeat.Name = str Then

''''                bRet = swFeat.Select2(True, 0)

''''                Exit Do

''''            ElseIf intPlane = intFound Then

''''                bRet = swFeat.Select2(True, 0)                'Primarily used for French Planes

''''            End If

''''             intFound = intFound + 1

        End If

        Set swFeat = swFeat.GetNextFeature

    Loop

    For i = 0 To 2

        If arrFeat(i).Name = str Then

            Set swFeat = arrFeat(i)

            bRet = swFeat.Select2(True, 0)

        End If

    Next i

    If swFeat Is Nothing Then

        Set swFeat = arrFeat(intPlane - 1)

        bRet = swFeat.Select2(True, 0)

    End If

    If DeSel Then bRet = swFeat.DeSelect

End Function

Sub AddParallelMate(assy As SldWorks.AssemblyDoc)

Set swMateFeature = assy.AddMate5(swMatePARALLEL, swMateAlignCLOSEST, False, 0, 0, 0, 0, 0, 0, 0, 0, False, False, 0, swAddMateError_ErrorUknown)

    ' Check if Mate is added or not

    If swMateFeature Is Nothing Then

      MsgBox "Failed to Add Mate."

      assy.ClearSelection2 True

      Exit Sub

    End If

End Sub

Sub AddCoincidentMate(assy As SldWorks.AssemblyDoc)

Set swMateFeature = assy.AddMate5(swMateCOINCIDENT, swMateAlignCLOSEST, False, 0, 0, 0, 0, 0, 0, 0, 0, False, False, 0, swAddMateError_ErrorUknown)

    ' Check if Mate is added or not

    If swMateFeature Is Nothing Then

      MsgBox "Failed to Add Mate."

      assy.ClearSelection2 True

      Exit Sub

    End If

End Sub

Sub SelMateEntities(model As SldWorks.ModelDoc2, mate As SldWorks.Mate2)

    Dim rootAssy As SldWorks.AssemblyDoc

    Dim swMateEnt As SldWorks.MateEntity2

    Dim swMateEnt2 As SldWorks.MateEntity2

    Set rootAssy = model

    Set swMateEnt = mate.MateEntity(0)

    Set swMateEnt2 = mate.MateEntity(1)

    rootAssy.ClearSelection2 True

    Set swSelMgr = model.SelectionManager

    Dim swSelData As SldWorks.SelectData

    Set swSelData = swSelMgr.CreateSelectData

    swSelData.Mark = 1

    bRet = swMateEnt.Reference.Select4(True, swSelData)

    bRet = swMateEnt2.Reference.Select4(True, swSelData)

End Sub

Function GetLastMate(comp As SldWorks.Component2) As SldWorks.Mate2

    Dim Mates As Variant

    Mates = comp.GetMates()

    If (Not IsEmpty(Mates)) Then

        Set GetLastMate = Mates(UBound(Mates))

    End If

End Function

Function DelLastMate(model As SldWorks.ModelDoc2, mate As SldWorks.Mate2)

        Dim feature As SldWorks.feature

        Set feature = model.Extension.GetLastFeatureAdded

        Dim featMate As SldWorks.Mate2

        Set featMate = feature.GetSpecificFeature2

        If (mate.Type <> featMate.Type) Then Exit Function 'Or (mate.MateEntity(0).Reference <> featMate.MateEntity(0).Reference) Or (mate.MateEntity(1).Reference <> featMate.MateEntity(1).Reference) Then Exit Function

        model.ClearSelection2 True

        feature.Select False

        model.EditDelete

End Function

Function TestMateTLA(mate As SldWorks.Mate2, model As SldWorks.ModelDoc2, intPlane As Integer, comp As SldWorks.Component2, intMate As Integer) As Boolean

    'If the given mate is between TLA plant (itrig) and comp

    'There are three states, the mate doesn't exist, parallel it, it does exist, upgrade it?

    TestMateTLA = False

    Dim str As String

    If mate Is Nothing Then

        TestMateTLA = False

        Exit Function

    End If

    str = Switch(intPlane = 1, "Front Plane", intPlane = 2, "Top Plane", intPlane = 3, "Right Plane")

    If mate.Type = intMate Then

            Dim Plane2Plane As Boolean

            Dim Entity  As SldWorks.MateEntity2

            For i = 0 To 1

                Set Entity = mate.MateEntity(i)

                If Entity.ReferenceType2 = swSelDATUMPLANES Then '4 = DatumPlane, 2 = Face

                   TestMateTLA = (Entity.Reference.Name = str) And (InStr(model.GetPathName, Entity.ReferenceComponent.Name) > 0)

                End If

            Next i

'            Dim Entity1  As SldWorks.MateEntity2

'            Dim Entity2  As SldWorks.MateEntity2

'            Set Entity1 = mate.MateEntity(0)

'            Set Entity2 = mate.MateEntity(1)

'

'

'            Debug.Print Entity1.ReferenceComponent.Name

'            Debug.Print Entity2.ReferenceComponent.Name

'

'            If Entity1.ReferenceType2 = 4 And Entity2.ReferenceType2 = 4 Then Plane2Plane = True

'''''            Debug.Print InStr(model.GetPathName, Entity1.ReferenceComponent.Name)

'''''            Debug.Print InStr(model.GetPathName, Entity2.ReferenceComponent.Name)

'''''            Debug.Print InStr(comp.GetPathName, Entity1.ReferenceComponent.Name)

'''''            Debug.Print InStr(comp.GetPathName, Entity2.ReferenceComponent.Name)

'

'

'            If Entity1.ReferenceType2 = swSelDATUMPLANES Then '4 = DatumPlane, 2 = Face

'                Debug.Print Entity1.Reference.Name = str

'            End If

'            If Entity2.ReferenceType2 = swSelDATUMPLANES Then '4 = DatumPlane, 2 = Face

'                Debug.Print Entity2.Reference.Name = str

'            End If

    End If

End Function

Function TestMateComp(mate As SldWorks.Mate2, comp1 As SldWorks.Component2, intPlane As Integer, comp2 As SldWorks.Component2, intMate As Integer) As Boolean

    'If the given mate is between TLA plant (itrig) and comp

    'There are three states, the mate doesn't exist, parallel it, it does exist, upgrade it?

    TestMateComp = False

    Dim str As String

    Dim name1 As String

    Dim name2 As String

    str = Switch(intPlane = 1, "Front Plane", intPlane = 2, "Top Plane", intPlane = 3, "Right Plane")

    If mate.Type = intMate Then

            Dim Plane2Plane As Boolean

            Dim Entity  As SldWorks.MateEntity2

            For i = 0 To 1

                Set Entity = mate.MateEntity(i)

                If Entity.ReferenceType2 = swSelDATUMPLANES Then '4 = DatumPlane, 2 = Face

                name1 = Entity.ReferenceComponent.Name

                name1 = Left(name1, InStrRev(name1, "-") - 1)

                   TestMateComp = (Entity.Reference.Name = str) And ((InStr(comp1.GetPathName, name1) > 0) Or (InStr(comp2.GetPathName, name1) > 0))

                End If

            Next i

    End If

End Function

''''''''----------------------------------------

'''''''' Preconditions:

'''''''' 1. Open public_documents\tutorial\advdrawings\bladed shaft.sldasm.

'''''''' 2. Open the Immediate window.

''''''''

'''''''' Postconditions:

'''''''' 1. Gets the components and mates.

'''''''' 2. Examine the Immediate window.

''''''''-----------------------------------------

'''''''

'''''''

'''''''

'''''''Sub GetMates(assy As SldWorks.AssemblyDoc, comp As SldWorks.Component2)

'''''''Dim swComponent As SldWorks.Component2

'''''''Dim swAssembly As SldWorks.AssemblyDoc

'''''''Dim Components As Variant

'''''''Dim SingleComponent As Variant

'''''''Dim Mates As Variant

'''''''Dim SingleMate As Variant

'''''''Dim swMateEnt As SldWorks.MateEntity2

'''''''Dim swMateEnt2 As SldWorks.MateEntity2

'''''''Dim swMateInPlace As SldWorks.MateInPlace

'''''''Dim numMateEntities As Long

'''''''Dim typeOfMate As Long

'''''''

'''''''    Set swApp = Application.SldWorks

'''''''    Set swModel = swApp.ActiveDoc

'''''''    Set swAssembly = swModel

'''''''

'''''''Dim CoincMateData As SldWorks.CoincidentMateFeatureData

'''''''Dim ParMateData As SldWorks.ParallelMateFeatureData

'''''''''''

'''''''''''    Components = swAssembly.GetComponents(False)

'''''''        Mates = comp.GetMates()

'''''''        If (Not IsEmpty(Mates)) Then

'''''''            Set swMate = Mates(UBound(Mates))

'''''''            If swMate.Type = 3 Then 'If parallel then make coincident

'''''''

'''''''                '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~DELETE MATE START

'''''''                Set swMateFeature = swModel.Extension.GetLastFeatureAdded

'''''''                assy.ClearSelection2 True

'''''''                swMateFeature.Select False

'''''''                swModel.EditDelete

'''''''                '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~DELETE MATE END

'''''''

'''''''                '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ADD MATE START

'''''''                Set swMateEnt = swMate.MateEntity(0)

'''''''                Set swMateEnt2 = swMate.MateEntity(1)

'''''''                Debug.Print swMateEnt.ReferenceComponent.name2

'''''''                Debug.Print swMateEnt2.ReferenceComponent.Name

'''''''                Dim swSelData As SldWorks.SelectData

'''''''                Set swSelData = swSelMgr.CreateSelectData

'''''''                assy.ClearSelection2 True

'''''''                swSelData.Mark = 1

'''''''                bRet = swMateEnt.Reference.Select4(True, swSelData)

'''''''                bRet = swMateEnt2.Reference.Select4(True, swSelData)

'''''''                Set swMateFeature = assy.AddMate5(swMateCOINCIDENT, swMateAlignCLOSEST, False, 0, 0, 0, 0, 0, 0, 0, 0, False, False, 0, swAddMateError_ErrorUknown)

'''''''                '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ADD MATE END

'''''''

'''''''

'''''''

'''''''

''''''''''''                        assy.EditMate3 0, 2, False, 0, 0, 0, 0, 0, 0, 0, 0, False, False, 0, swAddMateError_ErrorUknown  'Edit to Coincident

'''''''

''''''''''                    Set CoincMateData = assy.CreateMateData(0)

''''''''''                    Dim swMateFeatData As SldWorks.MateFeatureData

''''''''''                    Set swMateFeatData = swMate.GetDefinition 'LEAVEOFF - NEED TO FIND WAY TO MODIFY PARALLEL INTO COINCIDENT

''''''''''                                        Set ParMateData = swMateFeatData

''''''''''                    Set swMateFeatData = CoincMateData

''''''''''                    swMate.ModifyDefinition swMateFeatData, assy, Nothing

'''''''

''''''''''                Set swMateEnt = swMate.MateEntity(0)

''''''''''                Set swEnt = swMateEnt.Reference

''''''''''                bRet = swEnt.Select2(True, 0)

'''''''''''''                Dim swErrors As Long

''''''''''                assy.EditMate3 0, 2, False, 0, 0, 0, 0, 0, 0, 0, 0, False, False, 0, swAddMateError_ErrorUknown 'Edit to Coincident

'''''''                bRet = assy.EditRebuild3

'''''''            End If

'''''''        End If

'''''''End Sub

' this code is used in other works, credit to the authors must be placed in

' that work within a user viewable location (e.g., macro header).  All other

' forms of distribution (i.e., not free, fee for delivery, etc) are prohibited

' without the expressed written consent by the authors.  Use at your own risk!

' ------------------------------------------------------------------------------

' Written by: Deepak Gupta (http://gupta9665.wordpress.com/)

' -------------------------------------------------------------------------------

Dim swApp           As SldWorks.SldWorks

Dim swModel         As SldWorks.ModelDoc2

Dim swDraw          As SldWorks.DrawingDoc

Dim Filepath        As String

Dim FileName        As String

Dim boolstatus As Boolean

Dim longstatus As Long, longwarnings As Long

Sub main()

Set swApp = Application.SldWorks

Set swModel = swApp.ActiveDoc

' Check to see if a drawing is loaded.

If (swModel Is Nothing) Or (swModel.GetType <> swDocDRAWING) Then

swApp.SendMsgToUser ("To be used for drawings only, Open a drawing first and then TRY!")

' If no model currently loaded, then exit

Exit Sub

End If

Set swDraw = swModel

Filepath = Left(swDraw.GetPathName, InStrRev(swDraw.GetPathName, "\"))

FileName = Left(swDraw.GetTitle, Len(swDraw.GetTitle) - 9)

swDraw.SaveAs (Filepath + FileName + ".PDF")

End Sub

'Select Parent

'

'Author: Mahir Abrahim

'

'Date: 7/13/19

'

'Description: Selects parent assembly of the selected assembly component

'

'Preconditions:

'   (1) Assembly document is open.

'   (2) One or more items is selected.

'

'Postconditions: The last selected item is replaced by its parent assembly.

Option Explicit

Sub main()

    Dim swApp                       As SldWorks.SldWorks

    Dim swModel                     As SldWorks.ModelDoc2

    Dim swSelMgr                    As SldWorks.SelectionMgr

    Dim swSelComp                   As SldWorks.Component2

    Dim bRet                        As Boolean

    'Dim GeneralSelObj               As Object

    Dim i, j                           As Integer

    Dim CurSelCount                 As Long

    Dim NewObjToSelect              As Object

    Dim DwgDocComp                  As DrawingComponent

    Dim OldToggleVal                As Long

    Dim swEntity()                 As SldWorks.Entity

    Set swApp = Application.SldWorks

    Set swModel = swApp.ActiveDoc

    If swModel Is Nothing Then Exit Sub

''''    If swModel.GetType = swDocPART Then

''''        'MsgBox "This macro works on assembly documents or assembly drawings only."

''''        Exit Sub

''''    ElseIf (swModel.GetType = swDocDRAWING) Then

''''        If (swModel.ActiveDrawingView.ReferencedDocument.GetType = swDocPART) Then

''''            'MsgBox "This macro works on assembly documents or assembly drawings only."

''''            Exit Sub

''''        End If

''''    End If

    Set swSelMgr = swModel.SelectionManager

    CurSelCount = swSelMgr.GetSelectedObjectCount

    If CurSelCount = 0 Then

        MsgBox "Nothing was selected"

        Exit Sub

    End If

    'Set GeneralSelObj = swSelMgr.GetSelectedObject(CurSelCount)

    If swModel.GetType = swDocDRAWING Then

        Set DwgDocComp = swSelMgr.GetSelectedObjectsComponent2(CurSelCount)

        Set swSelComp = DwgDocComp.Component

    Else

        If swSelMgr.GetSelectedObjectType(CurSelCount) <> 20 Then

            For i = 1 To CurSelCount

                Set swSelComp = swSelMgr.GetSelectedObjectsComponent(i)

 '           GoTo SkipDesel

 '~~~~~~~~~~~~~~DESELECT FACE START

        Dim swFace                      As SldWorks.Face2

        Dim swFaceEnt()                 As SldWorks.Entity

        Dim swSelObj()                  As Object

        Dim vSelObj                     As Variant

        Dim vSectionProp                As Variant

        Dim nNumObj                     As Long

        Dim nSelType                    As Long

        nSelType = swSelMgr.GetSelectedObjectType2(1)

        If nSelType = swSelFACES Or nSelType = swSelREFSURFACES Then

                nNumObj = nNumObj + 1

                ReDim Preserve swSelObj(nNumObj - 1)

                ReDim Preserve swFaceEnt(nNumObj - 1)

                Set swFace = swSelMgr.GetSelectedObject5(1)

                Set swFaceEnt(nNumObj - 1) = swFace

                Set swSelObj(nNumObj - 1) = swFace

        End If

                    If Not IsEmpty(swFaceEnt) Then

                        For j = 0 To UBound(swFaceEnt)

                            swFaceEnt(j).DeSelect

                            Set swSelComp = swFaceEnt(j).GetComponent

                            swSelComp.Select (True)

                        Next j

                    End If

 '~~~~~~~~~~~~~~DESELECT FACE END

'SkipDesel:

                swSelComp.Select (True)

            Next i

            Exit Sub

        End If

        Set swSelComp = swSelMgr.GetSelectedObjectsComponent(CurSelCount)

    End If

    Set NewObjToSelect = swSelComp.GetParent

    If Not NewObjToSelect Is Nothing Then

        swSelMgr.DeSelect CurSelCount

        If swModel.GetType = swDocDRAWING Then

            Set NewObjToSelect = NewObjToSelect.GetDrawingComponent(swSelMgr.GetSelectedObject6(swSelMgr.GetSelectedObjectCount2(-1), -1))

            swModel.ClearSelection2 True

            OldToggleVal = swApp.GetUserPreferenceToggle(swAutoShowPropertyManager)

            swApp.SetUserPreferenceToggle swAutoShowPropertyManager, False

            bRet = NewObjToSelect.Select(True, Nothing)

            swApp.SetUserPreferenceToggle swAutoShowPropertyManager, OldToggleVal

        Else

            bRet = NewObjToSelect.Select(True)

        End If

        'Debug.Print bRet

    End If

End Sub

Option Explicit

Sub main()

    Dim swApp As SldWorks.SldWorks

    Dim swModel As SldWorks.ModelDoc2

    Dim swConfig As SldWorks.Configuration

    Dim swComp As SldWorks.Component2

    Dim bRet           As Boolean

    Dim i              As Integer

    Set swApp = CreateObject("SldWorks.Application")

    Set swModel = swApp.ActiveDoc

        ' Get active configuration and create a new display

    ' state for this configuration

    Set swConfig = swModel.GetActiveConfiguration

    bRet = swConfig.CreateDisplayState("COLOR")

    swModel.ForceRebuild3 True

    Dim swAssy As AssemblyDoc

    Dim myCmps

    Dim myCmp As Component2

    Dim vMatProp As Variant

    Set swAssy = swApp.ActiveDoc

    myCmps = swAssy.GetComponents(False)

    For i = 0 To UBound(myCmps)

        Set swComp = myCmps(i)

        If (swComp.GetSuppression <> 0) Then

            Dim strTitle As String

            strTitle = Split(swComp.GetSelectByIDString, "@")(0)

            strTitle = GetSubstringBeforeLastDash(strTitle)

            strTitle = GetSubstringBeforeLastDash(strTitle)

            ColorComps swAssy, strTitle

        End If

    Next i

End Sub

Function GetSubstringBeforeLastDash(str As String) As String

    Dim lastDashPosition As Integer

    lastDashPosition = InStrRev(str, "-")

    If lastDashPosition > 0 Then

        GetSubstringBeforeLastDash = Left(str, lastDashPosition - 1)

    Else

        GetSubstringBeforeLastDash = str

    End If

End Function

Function ColorComps(assy As SldWorks.AssemblyDoc, compName As String)

    Dim swComp As SldWorks.Component2

    Dim vComps As Variant

    Dim i As Long

    Dim vMatProp As Variant

    vComps = assy.GetComponents(False)

    vMatProp = assy.MaterialPropertyValues

    vMatProp(0) = Rnd()

        If vMatProp(0) < 0.4 Then vMatProp(0) = vMatProp(0) + 0.5

    vMatProp(1) = Rnd()

        If vMatProp(1) < 0.4 Then vMatProp(1) = vMatProp(1) + 0.5

    vMatProp(2) = Rnd()

        If vMatProp(2) < 0.4 Then vMatProp(2) = vMatProp(2) + 0.5

    If Not IsEmpty(vComps) Then

        For i = 0 To UBound(vComps)

            Set swComp = vComps(i)

            If InStr(1, swComp.Name2, compName) = 1 Then

                swComp.MaterialPropertyValues = vMatProp

            End If

        Next i

    End If

End Function

'**********************

'Copyright(C) 2022 Xarial Pty Limited

'Reference: https://www.codestack.net/solidworks-api/document/assembly/mates/flip-last/

'License: https://www.codestack.net/license/

'**********************

Dim swApp As SldWorks.SldWorks

Sub main()

    Set swApp = Application.SldWorks

    Dim swAssy As SldWorks.AssemblyDoc

    Set swAssy = swApp.ActiveDoc

    Dim swLastMate As SldWorks.Mate2

    Set swLastMate = GetLastMate(swAssy)

    Dim curAlignment As swMateAlign_e

    curAlignment = swLastMate.Alignment

    Dim destAlignment As swMateAlign_e

    If curAlignment = swMateAlignALIGNED Then

        destAlignment = swMateAlignANTI_ALIGNED

    ElseIf curAlignment = swMateAlignANTI_ALIGNED Then

        destAlignment = swMateAlignALIGNED

    Else

        Exit Sub

    End If

    Dim swMateFeat As SldWorks.Feature

    Set swMateFeat = swLastMate

    Dim swMateFeatData As SldWorks.MateFeatureData

    Set swMateFeatData = swMateFeat.GetDefinition

    Select Case swMateFeatData.TypeName

        Case swMateType_e.swMateANGLE

            Dim swAngleMateFeatData As SldWorks.AngleMateFeatureData

            Set swAngleMateFeatData = swMateFeatData

            swAngleMateFeatData.MateAlignment = destAlignment

        Case swMateType_e.swMateCAMFOLLOWER

            Dim swCamFollowerMateFeatData As SldWorks.CamFollowerMateFeatureData

            Set swCamFollowerMateFeatData = swMateFeatData

            swCamFollowerMateFeatData.MateAlignment = destAlignment

        Case swMateType_e.swMateCOINCIDENT

            Dim swCoincidentMateFeatData As SldWorks.CoincidentMateFeatureData

            Set swCoincidentMateFeatData = swMateFeatData

            swCoincidentMateFeatData.MateAlignment = destAlignment

        Case swMateType_e.swMateCONCENTRIC

            Dim swConcentricMateFeatData As SldWorks.ConcentricMateFeatureData

            Set swConcentricMateFeatData = swMateFeatData

            swConcentricMateFeatData.MateAlignment = destAlignment

        Case swMateType_e.swMateDISTANCE

            Dim swDistanceMateFeatData As SldWorks.DistanceMateFeatureData

            Set swDistanceMateFeatData = swMateFeatData

            swDistanceMateFeatData.MateAlignment = destAlignment

        Case swMateType_e.swMateHINGE

            Dim swHingeMateFeatData As SldWorks.HingeMateFeatureData

            Set swHingeMateFeatData = swMateFeatData

            swHingeMateFeatData.MateAlignment = destAlignment

        Case swMateType_e.swMatePARALLEL

            Dim swParallelMateFeatData As SldWorks.ParallelMateFeatureData

            Set swParallelMateFeatData = swMateFeatData

            swParallelMateFeatData.MateAlignment = destAlignment

        Case swMateType_e.swMatePROFILECENTER

            Dim swProfileCenterMateFeatData As SldWorks.ProfileCenterMateFeatureData

            Set swProfileCenterMateFeatData = swMateFeatData

            swProfileCenterMateFeatData.MateAlignment = destAlignment

        Case swMateType_e.swMateSCREW

            Dim swScrewMateFeatData As SldWorks.ScrewMateFeatureData

            Set swScrewMateFeatData = swMateFeatData

            swScrewMateFeatData.MateAlignment = destAlignment

        Case swMateType_e.swMateSLOT

            Dim swSlotMateFeatData As SldWorks.SlotMateFeatureData

            Set swSlotMateFeatData = swMateFeatData

            swSlotMateFeatData.MateAlignment = destAlignment

        Case swMateType_e.swMateSYMMETRIC

            Dim swSymmetricMateFeatData As SldWorks.SymmetricMateFeatureData

            Set swSymmetricMateFeatData = swMateFeatData

            swSymmetricMateFeatData.MateAlignment = destAlignment

        Case swMateType_e.swMateTANGENT

            Dim swTangentMateFeatData As SldWorks.TangentMateFeatureData

            Set swTangentMateFeatData = swMateFeatData

            swTangentMateFeatData.MateAlignment = destAlignment

        Case Else

            Err.Raise vbError, "", "Not supported mate type"

    End Select

    swMateFeat.ModifyDefinition swMateFeatData, swAssy, Nothing

End Sub

Function GetLastMate(assm As SldWorks.AssemblyDoc) As SldWorks.Mate2

    Dim swMates() As SldWorks.Feature

    Dim isInit As Boolean

    isInit = False

    Dim swModel As SldWorks.ModelDoc2

    Set swModel = assm

    Dim swMateGroupFeat As SldWorks.Feature

    Dim featIndex As Integer

    featIndex = 0

    Do

        Set swMateGroupFeat = swModel.FeatureByPositionReverse(featIndex)

        featIndex = featIndex + 1

    Loop While swMateGroupFeat.GetTypeName2() <> "MateGroup"

    Dim swLastMateFeat As SldWorks.Feature

    Dim swMateFeat As SldWorks.Feature

    Set swMateFeat = swMateGroupFeat.GetFirstSubFeature

    While Not swMateFeat Is Nothing

        If TypeOf swMateFeat.GetSpecificFeature2() Is SldWorks.Mate2 Then

            Set swLastMateFeat = swMateFeat

        End If

        Set swMateFeat = swMateFeat.GetNextSubFeature

    Wend

    Debug.Print swLastMateFeat.Name

    Set GetLastMate = swLastMateFeat.GetSpecificFeature2

End Function

' Variable for Solidworks Application

Dim swApp As SldWorks.SldWorks

' Variable for Solidworks document

Dim swDoc As SldWorks.ModelDoc2

' Variable for Solidworks Assembly

Dim swAssembly As SldWorks.AssemblyDoc

' Variable for Solidworks Mate Feature

Dim swMateFeature As SldWorks.Feature

' Program to Delete selected feature

Sub main()

  ' Set Solidworks Application variable to current application

  Set swApp = Application.SldWorks

  ' Set Solidworks document variable to currently opened document

  Set swDoc = swApp.ActiveDoc

  ' Check if Solidworks document is opened or not

  If swDoc Is Nothing Then

    MsgBox "Solidworks document is not opened."

    Exit Sub

  End If

  ' Set Solidworks Assembly document

  Set swAssembly = swDoc

  ' Get mate feature

  Set swMateFeature = swDoc.Extension.GetLastFeatureAdded

  ' Check if successfully Get feature

  If swMateFeature Is Nothing Then

    MsgBox "Failed to Get feature."

    swDoc.ClearSelection2 True

    Exit Sub

  End If

  ' Select the mate

  swMateFeature.Select True

  ' Delete selected item

  swDoc.EditDelete

End Sub