Macro to Mate Origin - Origin

[zwei]

Asking around before i start writing my own macro...

Do anyone has a macro or similar macro that do the following?

The current idea for the workflow is that:
1. Select TWO component in feature tree
2. Run the macro
3. The macro mate the two component together using origin

[Stefan Sterk]

Hi Zhen,

The code that follows fulfills your request. The only issue I can identify is that the Origin Axes don't align as they would if I did it manually.

Code: Select all

Sub main()
    Dim swApp As SldWorks.SldWorks
    Dim swModel As SldWorks.ModelDoc2
    Dim swAsm As SldWorks.AssemblyDoc
    Dim swSelMgr As SldWorks.SelectionMgr
    Dim swSelComp As SldWorks.Component2
    Dim swSelComp1 As SldWorks.Component2
    Dim swSelComp2 As SldWorks.Component2
    Dim swFeat As SldWorks.Feature
    Dim swSketch As SldWorks.Sketch
    Dim swSkPoint As SldWorks.SketchPoint
    Dim swCoincMateData As SldWorks.CoincidentMateFeatureData
    Dim EntitiesToMate(1) As Object
    Dim EntitiesToMateVar As Variant
    Dim i As Integer

    Set swApp = Application.SldWorks
    Set swModel = swApp.ActiveDoc
    
    If swModel Is Nothing Then MsgBox "Please open a Assembly!": End
    If swModel.GetType <> swDocASSEMBLY Then MsgBox "Please open a Assembly!": End
    
    Set swAsm = swModel
    Set swSelMgr = swModel.SelectionManager
    Set swSelComp1 = swSelMgr.GetSelectedObjectsComponent(1)
    Set swSelComp2 = swSelMgr.GetSelectedObjectsComponent(2)
    
    ' Check selection
    If swSelMgr.GetSelectedObjectCount2(-1) > 2 Then MsgBox "Please select only two components!": End
    If swSelMgr.GetSelectedObjectCount2(-1) <> 2 Then MsgBox "Please select two components!": End
    If swSelComp1 Is Nothing Or swSelComp2 Is Nothing Then MsgBox "Please select two components!": End
    
    ' Get origins to mate
    For i = 0 To 1
        Set swSelComp = swSelMgr.GetSelectedObjectsComponent(i + 1)
        Set swFeat = swSelComp.FirstFeature
        Do While Not swFeat Is Nothing
            If "OriginProfileFeature" = swFeat.GetTypeName Then
                Set swSketch = swFeat.GetSpecificFeature2
                Set swSkPoint = swSketch.GetSketchPoints2()(0)
                Set EntitiesToMate(i) = swSkPoint
                Exit Do
            End If
            Set swFeat = swFeat.GetNextFeature
        Loop
    Next i
    EntitiesToMateVar = EntitiesToMate

    ' Create CoincidentMateFeatureData
    Set swCoincMateData = swModel.CreateMateData(0)
    swCoincMateData.EntitiesToMate = (EntitiesToMateVar)
    swCoincMateData.MateAlignment = 0
    swModel.CreateMate swCoincMateData
    
End Sub

[Stefan Sterk]

I contacted API Support and they suggest using AddMate5 with swMateCOORDINATE, which will align the axes.
The code snippet below works as expected. Have fun with it

Code: Select all

Sub main()
    Dim swApp As SldWorks.SldWorks
    Dim swModel As SldWorks.ModelDoc2
    Dim swAsm As SldWorks.AssemblyDoc
    Dim swSelMgr As SldWorks.SelectionMgr
    Dim swFeat As SldWorks.Feature
    Dim swSketch As SldWorks.Sketch
    Dim swSkPoint As SldWorks.SketchPoint
    Dim SelComps(1) As Object
    Dim i As Integer

    Set swApp = Application.SldWorks
    Set swModel = swApp.ActiveDoc
    
    If swModel Is Nothing Then MsgBox "Please open a Assembly!": End
    If swModel.GetType <> swDocASSEMBLY Then MsgBox "Please open a Assembly!": End
    
    Set swAsm = swModel
    Set swSelMgr = swModel.SelectionManager
    Set SelComps(0) = swSelMgr.GetSelectedObjectsComponent(1)
    Set SelComps(1) = swSelMgr.GetSelectedObjectsComponent(2)
    
    If swSelMgr.GetSelectedObjectCount2(-1) > 2 Then MsgBox "Please select only two components!": End
    If swSelMgr.GetSelectedObjectCount2(-1) <> 2 Then MsgBox "Please select two components!": End
    If SelComps(0) Is Nothing Or SelComps(1) Is Nothing Then MsgBox "Please select two components!": End
    
    swModel.ClearSelection2 True
    For i = 0 To 1
        Set swFeat = SelComps(i).FirstFeature
        Do While Not swFeat Is Nothing
            If "OriginProfileFeature" = swFeat.GetTypeName Then
                Set swSketch = swFeat.GetSpecificFeature2
                Set swSkPoint = swSketch.GetSketchPoints2()(0)
                swSkPoint.Select4 True, Nothing
                Exit Do
            End If
            Set swFeat = swFeat.GetNextFeature
        Loop
    Next i
    
    swAsm.AddMate5 20, -1, False, 0, 0, 0, 0, 0, 0, 0, 0, False, False, 0, Empty
    swModel.EditRebuild3
    swModel.ClearSelection2 True
    
End Sub

[AlexLachance]

Hey guys, just stopping by to hola at both of you!

[zwei]

I contacted API Support and they suggest using AddMate5 with swMateCOORDINATE, which will align the axes.
The code snippet below works as expected. Have fun with it

Code: Select all

Sub main()
    Dim swApp As SldWorks.SldWorks
    Dim swModel As SldWorks.ModelDoc2
    Dim swAsm As SldWorks.AssemblyDoc
    Dim swSelMgr As SldWorks.SelectionMgr
    Dim swFeat As SldWorks.Feature
    Dim swSketch As SldWorks.Sketch
    Dim swSkPoint As SldWorks.SketchPoint
    Dim SelComps(1) As Object
    Dim i As Integer

    Set swApp = Application.SldWorks
    Set swModel = swApp.ActiveDoc
    
    If swModel Is Nothing Then MsgBox "Please open a Assembly!": End
    If swModel.GetType <> swDocASSEMBLY Then MsgBox "Please open a Assembly!": End
    
    Set swAsm = swModel
    Set swSelMgr = swModel.SelectionManager
    Set SelComps(0) = swSelMgr.GetSelectedObjectsComponent(1)
    Set SelComps(1) = swSelMgr.GetSelectedObjectsComponent(2)
    
    If swSelMgr.GetSelectedObjectCount2(-1) > 2 Then MsgBox "Please select only two components!": End
    If swSelMgr.GetSelectedObjectCount2(-1) <> 2 Then MsgBox "Please select two components!": End
    If SelComps(0) Is Nothing Or SelComps(1) Is Nothing Then MsgBox "Please select two components!": End
    
    swModel.ClearSelection2 True
    For i = 0 To 1
        Set swFeat = SelComps(i).FirstFeature
        Do While Not swFeat Is Nothing
            If "OriginProfileFeature" = swFeat.GetTypeName Then
                Set swSketch = swFeat.GetSpecificFeature2
                Set swSkPoint = swSketch.GetSketchPoints2()(0)
                swSkPoint.Select4 True, Nothing
                Exit Do
            End If
            Set swFeat = swFeat.GetNextFeature
        Loop
    Next i
    
    swAsm.AddMate5 20, -1, False, 0, 0, 0, 0, 0, 0, 0, 0, False, False, 0, Empty
    swModel.EditRebuild3
    swModel.ClearSelection2 True
    
End Sub

Sorry for the late reply... This totally slipped my mind after my vacation...

The macro work like a charm

Thanks a lot.

[mp3-250]

I was trying addmate5 for a while and the answer helped me to understand the problem was the axis alignment required an undocumented "-1" after the swMateCOORDINATE "20". lol

Thank you!

https://help.solidworks.com/2024/Englis ... Redirect=1

Member Description
swAlignAGAINST Obsolete. Do not use.
swAlignNONE Obsolete. Do not use.
swAlignSAME Obsolete. Do not use.
swMateAlignALIGNED 0
swMateAlignANTI_ALIGNED 1
swMateAlignCLOSEST 2