Plane/Origin Selection Macro
Plane/Origin Selection Macro
(OP)
One thing that's always been a little inconvenient to me is selecting the original 3 planes or origin of a component in an assembly for mating or other purposes. You have to click the component, find it in the design tree, expand it out, and pick the desired plane. I finally got tired enough of doing that to write this macro. It works best when assigned to a keyboard shortcut (I have mine mapped to "R"). To use it, select any component in an assembly. It may be a part, subassembly, or a part of a subassembly (any depth). Then run the macro. It will select the origin of the component. When run multiple times without the user changing selections it will cycle through selecting the origin and the 3 primary planes in succession. You can actually make multiple selections and the macro will only operate on the last selected component without losing your other selections.
The only thing that stinks is that macros are disabled while the "mate" property manager is displayed.
This macro is loosely based on an example in the API help for selecting the origin of an assembly component. However, when you mate the origin of a component in an assembly it is actually mating "Point1@Origin@....". Figuring out how to select that Point1 correctly at any depth of subassembly gave me fits, but I think it's right.
Hope it's useful to you!
The only thing that stinks is that macros are disabled while the "mate" property manager is displayed.
This macro is loosely based on an example in the API help for selecting the origin of an assembly component. However, when you mate the origin of a component in an assembly it is actually mating "Point1@Origin@....". Figuring out how to select that Point1 correctly at any depth of subassembly gave me fits, but I think it's right.
Hope it's useful to you!
CODE
'-------------------------------------------------
' Macro to select main reference geometry of an assembly component
' for easy mating. Modified extensively from the
' "Select Origin of Assembly Component Example (VB)" in
' SolidWorks and Add-Ins API Help
' Preconditions:
' (1) Assembly document is open.
' (2) One or more items is selected.
'
' Postconditions: One of the 3 original planes or the
' origin of the last selected component is selected.
'
'--------------------------------------------------
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 swCompModel As SldWorks.ModelDoc2
Dim swFeat As SldWorks.Feature
Dim bRet As Boolean
Dim GeneralSelObj As Object
Dim myFeatureCollection As New Collection
Dim i As Integer
Dim CurSelCount As Long
Dim MyTempPointObj As Object
Dim mySelStr As String
Dim NewObjToSelect As Object
Dim Chunks As Variant
Set swApp = Application.SldWorks
Set swModel = swApp.ActiveDoc
If swModel.GetType <> swDocASSEMBLY Then
MsgBox "This macro works on assembly documents only."
Exit Sub
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)
Set swSelComp = swSelMgr.GetSelectedObjectsComponent(CurSelCount)
' Set swCompModel = swSelComp.GetModelDoc
swSelMgr.DeSelect CurSelCount
Set swFeat = swSelComp.FirstFeature
Do While Not swFeat Is Nothing
If "RefPlane" = swFeat.GetTypeName Then
myFeatureCollection.Add swFeat
End If
If "OriginProfileFeature" = swFeat.GetTypeName Then
Chunks = Split(swSelComp.Name2, "/")
mySelStr = "Point1@Origin@" & Chunks(0) & "@" & _
Left(swModel.GetTitle, Len(swModel.GetTitle) - 7)
For i = 0 To (UBound(Chunks) - 1)
mySelStr = mySelStr & "/" & Chunks(i + 1) & "@" & Left(Chunks(i), (InStrRev(Chunks(i), "-") - 1))
Next
swModel.Extension.SelectByID2 mySelStr, "EXTSKETCHPOINT", _
0, 0, 0, True, 0, Nothing, swSelectOptionDefault
myFeatureCollection.Add swSelMgr.GetSelectedObject(swSelMgr.GetSelectedObjectCount)
swModel.Extension.SelectByID2 mySelStr, "EXTSKETCHPOINT", _
0, 0, 0, True, 0, Nothing, swSelectOptionDefault
Exit Do
End If
Set swFeat = swFeat.GetNextFeature
Loop
Set NewObjToSelect = Nothing
'MsgBox myFeatureCollection.Count
If myFeatureCollection.Count > 4 Then
MsgBox "Error: more than three planes before origin in design tree!"
Exit Sub
End If
For i = 1 To myFeatureCollection.Count
If GeneralSelObj Is myFeatureCollection.Item(i) Then
Set NewObjToSelect = myFeatureCollection.Item((i Mod myFeatureCollection.Count) + 1)
'Use of Mod above cycles back to first item if last item matches.
End If
Next
If NewObjToSelect Is Nothing Then
Set NewObjToSelect = myFeatureCollection.Item(myFeatureCollection.Count)
End If
bRet = NewObjToSelect.Select(True): Debug.Assert bRet
End Sub
'-------------------------------------------------
' Macro to select main reference geometry of an assembly component
' for easy mating. Modified extensively from the
' "Select Origin of Assembly Component Example (VB)" in
' SolidWorks and Add-Ins API Help
' Preconditions:
' (1) Assembly document is open.
' (2) One or more items is selected.
'
' Postconditions: One of the 3 original planes or the
' origin of the last selected component is selected.
'
'--------------------------------------------------
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 swCompModel As SldWorks.ModelDoc2
Dim swFeat As SldWorks.Feature
Dim bRet As Boolean
Dim GeneralSelObj As Object
Dim myFeatureCollection As New Collection
Dim i As Integer
Dim CurSelCount As Long
Dim MyTempPointObj As Object
Dim mySelStr As String
Dim NewObjToSelect As Object
Dim Chunks As Variant
Set swApp = Application.SldWorks
Set swModel = swApp.ActiveDoc
If swModel.GetType <> swDocASSEMBLY Then
MsgBox "This macro works on assembly documents only."
Exit Sub
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)
Set swSelComp = swSelMgr.GetSelectedObjectsComponent(CurSelCount)
' Set swCompModel = swSelComp.GetModelDoc
swSelMgr.DeSelect CurSelCount
Set swFeat = swSelComp.FirstFeature
Do While Not swFeat Is Nothing
If "RefPlane" = swFeat.GetTypeName Then
myFeatureCollection.Add swFeat
End If
If "OriginProfileFeature" = swFeat.GetTypeName Then
Chunks = Split(swSelComp.Name2, "/")
mySelStr = "Point1@Origin@" & Chunks(0) & "@" & _
Left(swModel.GetTitle, Len(swModel.GetTitle) - 7)
For i = 0 To (UBound(Chunks) - 1)
mySelStr = mySelStr & "/" & Chunks(i + 1) & "@" & Left(Chunks(i), (InStrRev(Chunks(i), "-") - 1))
Next
swModel.Extension.SelectByID2 mySelStr, "EXTSKETCHPOINT", _
0, 0, 0, True, 0, Nothing, swSelectOptionDefault
myFeatureCollection.Add swSelMgr.GetSelectedObject(swSelMgr.GetSelectedObjectCount)
swModel.Extension.SelectByID2 mySelStr, "EXTSKETCHPOINT", _
0, 0, 0, True, 0, Nothing, swSelectOptionDefault
Exit Do
End If
Set swFeat = swFeat.GetNextFeature
Loop
Set NewObjToSelect = Nothing
'MsgBox myFeatureCollection.Count
If myFeatureCollection.Count > 4 Then
MsgBox "Error: more than three planes before origin in design tree!"
Exit Sub
End If
For i = 1 To myFeatureCollection.Count
If GeneralSelObj Is myFeatureCollection.Item(i) Then
Set NewObjToSelect = myFeatureCollection.Item((i Mod myFeatureCollection.Count) + 1)
'Use of Mod above cycles back to first item if last item matches.
End If
Next
If NewObjToSelect Is Nothing Then
Set NewObjToSelect = myFeatureCollection.Item(myFeatureCollection.Count)
End If
bRet = NewObjToSelect.Select(True): Debug.Assert bRet
End Sub
'-------------------------------------------------






RE: Plane/Origin Selection Macro
Cool. Thanks. Works great sep for a bug I've found: I'm running into a debug error when a lightweight component is selected prior to running the macro. I am running 2005, so I'm not sure this would be an issue in near S/W.
Also, would you mind if I included this macro on my site?
Matt
CAD Engineer/ECN Analyst
Silicon Valley, CA
http://sw.fcsuper.com/index.php
RE: Plane/Origin Selection Macro
Try this version. It will check the version of SolidWorks that is currently running. If the version is earlier than 2006 it will then check the suppression state. If the component is not resolved it will either resolve it or exit the macro based on user choice. I don't have 2005 to check this on, but it resolves components correctly when I change the minimum release to 2007 rather than 2006.
Feel free to put it up on your site - just make sure the header plugs Eng-Tips!
CODE
' Macro to select main reference geometry of an assembly component
' for easy mating. Modified extensively from the
' "Select Origin of Assembly Component Example (VB)" in
' SolidWorks and Add-Ins API Help
' Preconditions:
' (1) Assembly document is open.
' (2) One or more items is selected.
'
' Postconditions: One of the 3 original planes or the
' origin of the last selected component is selected.
'
'--------------------------------------------------
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 swCompModel As SldWorks.ModelDoc2
Dim swFeat As SldWorks.Feature
Dim bRet As Boolean
Dim GeneralSelObj As Object
Dim myFeatureCollection As New Collection
Dim i As Integer
Dim CurSelCount As Long
Dim MyTempPointObj As Object
Dim mySelStr As String
Dim NewObjToSelect As Object
Dim Chunks As Variant
Dim swVer As Variant
Dim ResolveIt As Integer
Set swApp = Application.SldWorks
Set swModel = swApp.ActiveDoc
If swModel.GetType <> swDocASSEMBLY Then
MsgBox "This macro works on assembly documents only."
Exit Sub
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)
Set swSelComp = swSelMgr.GetSelectedObjectsComponent(CurSelCount)
swVer = Split(swApp.RevisionNumber, ".")
If CInt(swVer(0)) < 14 Then
If swSelComp.GetSuppression <> swComponentFullyResolved Then
If swSelComp.GetSuppression <> swComponentResolved Then
ResolveIt = MsgBox("The component selected is not fully resolved." _
& vbCrLf & "This functionality is only available for lightweight" & vbCrLf & _
"components in SolidWorks 2006 or greater." & vbCrLf & vbCrLf & _
"Resolve this component now?", vbYesNo, "Upgrade Time!")
If vbYes = ResolveIt Then
swSelComp.SetSuppression2 swComponentFullyResolved
Else
Exit Sub
End If
End If
End If
End If
swSelMgr.DeSelect CurSelCount
Set swFeat = swSelComp.FirstFeature
Do While Not swFeat Is Nothing
If "RefPlane" = swFeat.GetTypeName Then
myFeatureCollection.Add swFeat
End If
If "OriginProfileFeature" = swFeat.GetTypeName Then
Chunks = Split(swSelComp.Name2, "/")
mySelStr = "Point1@Origin@" & Chunks(0) & "@" & _
Left(swModel.GetTitle, Len(swModel.GetTitle) - 7)
For i = 0 To (UBound(Chunks) - 1)
mySelStr = mySelStr & "/" & Chunks(i + 1) & "@" & Left(Chunks(i), (InStrRev(Chunks(i), "-") - 1))
Next
swModel.Extension.SelectByID2 mySelStr, "EXTSKETCHPOINT", _
0, 0, 0, True, 0, Nothing, swSelectOptionDefault
myFeatureCollection.Add swSelMgr.GetSelectedObject(swSelMgr.GetSelectedObjectCount)
swModel.Extension.SelectByID2 mySelStr, "EXTSKETCHPOINT", _
0, 0, 0, True, 0, Nothing, swSelectOptionDefault
Exit Do
End If
Set swFeat = swFeat.GetNextFeature
Loop
Set NewObjToSelect = Nothing
'MsgBox myFeatureCollection.Count
If myFeatureCollection.Count > 4 Then
MsgBox "Error: more than three planes before origin in design tree!"
Exit Sub
End If
For i = 1 To myFeatureCollection.Count
If GeneralSelObj Is myFeatureCollection.Item(i) Then
Set NewObjToSelect = myFeatureCollection.Item((i Mod myFeatureCollection.Count) + 1)
'Use of Mod above cycles back to first item if last item matches.
End If
Next
If NewObjToSelect Is Nothing Then
Set NewObjToSelect = myFeatureCollection.Item(myFeatureCollection.Count)
End If
bRet = NewObjToSelect.Select(True): Debug.Assert bRet
End Sub
'-------------------------------------------------
RE: Plane/Origin Selection Macro
Works good. Thanks!
Matt
CAD Engineer/ECN Analyst
Silicon Valley, CA
http://sw.fcsuper.com/index.php
RE: Plane/Origin Selection Macro
This is a great time saving macro, I know I'll use it a lot - THANKS. My only question is can it be used to cycle through any other planes that are created and appear later in the feature manager tree. An example would be, often on a pipe fitting I'll add an "Installation Plane" at the approximate location on the threaded end for thread engagement into the next part.
thanks,
RacingD98
RE: Plane/Origin Selection Macro
Craig Sink
Mechanical Engineer
Force Design, Inc.
www.forcedesign.biz
RE: Plane/Origin Selection Macro
I added another constant (FIRSTREF) that you can change to start the cycling with one of the 3 primary planes rather than the origin.
I also caught (and fixed, of course) a bug that occurred when the macro was run before the assembly was saved.
I've ended up using this macro even more than I thought I would. Because I do one-off automation equipment design I use a lot of simple mates. I wrote three more macros to go along with this one since macros don't work with the Mate command active. I can post those if anyone's interested. They will add a Coincident, Parallel, or Concentric mate to pre-selected entities with a single button press without activating the Mate command and property manager. They actually run faster than the Mate command because they rely on your judgement to pre-select entities that are suitable for each mate rather than checking your selection set for all possible mate types.
Anyway, here's the new reference geometry selection macro:
CODE
' Macro to select main reference geometry of an assembly component
' for easy mating. Modified extensively from the
' "Select Origin of Assembly Component Example (VB)" in
' SolidWorks and Add-Ins API Help
' Preconditions:
' (1) Assembly document is open.
' (2) One or more items is selected.
'
' Postconditions: One of the reference planes or the
' origin of the last selected component is selected.
'
'--------------------------------------------------
Const STOPATORIGIN As Boolean = True
Const FIRSTREF As Long = 4
'Change the value of FIRSTREF above if you want
'one of the primary planes to be the first feature
'selected by the macro. Values are:
'Front = 1
'Top = 2
'Right = 3
'Origin = 4
'''''''''
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 swCompModel As SldWorks.ModelDoc2
Dim swFeat As SldWorks.Feature
Dim bRet As Boolean
Dim GeneralSelObj As Object
Dim myFeatureCollection As New Collection
Dim i As Integer
Dim CurSelCount As Long
Dim MyTempPointObj As Object
Dim mySelStr As String
Dim NewObjToSelect As Object
Dim Chunks As Variant
Dim swVer As Variant
Dim ResolveIt As Integer
Dim DocTitle As String
Set swApp = Application.SldWorks
Set swModel = swApp.ActiveDoc
If swModel.GetType <> swDocASSEMBLY Then
MsgBox "This macro works on assembly documents only."
Exit Sub
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)
Set swSelComp = swSelMgr.GetSelectedObjectsComponent(CurSelCount)
swVer = Split(swApp.RevisionNumber, ".")
If CInt(swVer(0)) < 14 Then
If swSelComp.GetSuppression <> swComponentFullyResolved Then
If swSelComp.GetSuppression <> swComponentResolved Then
ResolveIt = MsgBox("The component selected is not fully resolved." _
& vbCrLf & "This functionality is only available for lightweight" & vbCrLf & _
"components in SolidWorks 2006 or greater." & vbCrLf & vbCrLf & _
"Resolve this component now?", vbYesNo, "Upgrade Time!")
If vbYes = ResolveIt Then
swSelComp.SetSuppression2 swComponentFullyResolved
Else
Exit Sub
End If
End If
End If
End If
swSelMgr.DeSelect CurSelCount
Set swFeat = swSelComp.FirstFeature
Do While Not swFeat Is Nothing
If "RefPlane" = swFeat.GetTypeName Then
myFeatureCollection.Add swFeat
End If
If "OriginProfileFeature" = swFeat.GetTypeName Then
Chunks = Split(swSelComp.Name2, "/")
If StrComp(Right(swModel.GetTitle, 7), ".sldasm", vbTextCompare) <> 0 Then
DocTitle = swModel.GetTitle
Else
DocTitle = Left(swModel.GetTitle, Len(swModel.GetTitle) - 7)
End If
mySelStr = "Point1@Origin@" & Chunks(0) & "@" & DocTitle
For i = 0 To (UBound(Chunks) - 1)
mySelStr = mySelStr & "/" & Chunks(i + 1) & "@" & Left(Chunks(i), (InStrRev(Chunks(i), "-") - 1))
Next
swModel.Extension.SelectByID2 mySelStr, "EXTSKETCHPOINT", _
0, 0, 0, True, 0, Nothing, swSelectOptionDefault
myFeatureCollection.Add swSelMgr.GetSelectedObject(swSelMgr.GetSelectedObjectCount)
swModel.Extension.SelectByID2 mySelStr, "EXTSKETCHPOINT", _
0, 0, 0, True, 0, Nothing, swSelectOptionDefault
If STOPATORIGIN Then
Exit Do
End If
End If
Set swFeat = swFeat.GetNextFeature
Loop
Set NewObjToSelect = Nothing
For i = 1 To myFeatureCollection.Count
If GeneralSelObj Is myFeatureCollection.Item(i) Then
Set NewObjToSelect = myFeatureCollection.Item((i Mod myFeatureCollection.Count) + 1)
'Use of Mod above cycles back to first item if last item matches.
End If
Next
If NewObjToSelect Is Nothing Then
Set NewObjToSelect = myFeatureCollection.Item(FIRSTREF)
End If
bRet = NewObjToSelect.Select(True): Debug.Assert bRet
End Sub
'-------------------------------------------------
RE: Plane/Origin Selection Macro
Craig Sink
Mechanical Engineer
Force Design, Inc.
www.forcedesign.biz
RE: Plane/Origin Selection Macro
Your new version is even better than the first, thanks again. I too would be interested in the macros, anything to do my job faster.
RacingD98
RE: Plane/Origin Selection Macro
Enjoy!
Coincident mate:
CODE
Dim swDoc As SldWorks.ModelDoc2
Dim swAssy As SldWorks.AssemblyDoc
Dim swSelMgr As SldWorks.SelectionMgr
Dim swMate As SldWorks.Mate2
Dim ErrorLong As Long
Dim MsgReply As Integer
Dim NewAlign As Long
Sub main()
Set swApp = Application.SldWorks
Set swDoc = swApp.ActiveDoc
Set swAssy = swDoc
Set swSelMgr = swDoc.SelectionManager
If swDoc.GetType <> swDocASSEMBLY Then
MsgBox "Use this macro in Assembly documents only.", vbCritical
Exit Sub
End If
If swSelMgr.GetSelectedObjectCount <> 2 Then
MsgBox swSelMgr.GetSelectedObjectCount & " items selected. Req'd number is 2.", vbCritical
Exit Sub
End If
Set swMate = swAssy.AddMate3(swMateCOINCIDENT, swMateAlignCLOSEST, False, 0, 0, 0, 0, 0, 0, 0, 0, False, ErrorLong)
If Nothing Is swMate Then
MsgBox "Mating Error #" & ErrorLong & " Mate not added.", vbCritical
Exit Sub
End If
If swAddMateError_OverDefinedAssembly = ErrorLong Then
MsgReply = MsgBox("Overdefining mate. Keep anyway?", vbYesNo + vbQuestion)
If vbNo = MsgReply Then
swDoc.ClearSelection2 True
swMate.Select True
swDoc.Extension.DeleteSelection2 0
Else
'swDoc.EditRebuild3
End If
ElseIf swMate.Alignment <> swMateAlignCLOSEST Then
MsgReply = MsgBox("Keep current alignment?", vbYesNo, "Mate Alignment")
If vbNo = MsgReply Then
If swMate.Alignment = swMateAlignALIGNED Then
NewAlign = swMateAlignANTI_ALIGNED
Else
NewAlign = swMateAlignALIGNED
End If
swMate.Select True
swAssy.EditMate2 swMateCOINCIDENT, NewAlign, False, 0, 0, 0, 0, 0, 0, 0, 0, ErrorLong
If swAddMateError_OverDefinedAssembly = ErrorLong Then
MsgReply = MsgBox("Flip caused errors. Undo?", vbYesNo + vbQuestion)
If vbYes = MsgReply Then
swDoc.EditUndo2 1
End If
End If
'swDoc.EditRebuild3
End If
ElseIf swAddMateError_NoError <> ErrorLong Then
MsgBox "Mate error #" & ErrorLong & vbCrLf & "Mate not added"
If Not swMate Is Nothing Then
swDoc.ClearSelection2 True
swMate.Select True
swDoc.Extension.DeleteSelection2 0
End If
ElseIf swMate.GetErrorCode <> swFeatureErrorNone Then
Select Case swMate.GetErrorCode
Case swFeatureErrorMateInvalidEdge
MsgBox "Invalid edge"
Case swFeatureErrorMateInvalidFace
MsgBox "Invalid Face"
Case swFeatureErrorMateFailedCreatingSurface
MsgBox "Mate surface type not supported"
Case swFeatureErrorMateInvalidEntity
MsgBox "Supressed, Invalid, or Missing Entity"
Case swFeatureErrorMateDanglingGeometry
MsgBox "Mate geometry is dangling"
Case swFeatureErrorMateEntityNotLinear
MsgBox "Non-linear edges cannot be used for mating"
Case swFeatureErrorMateOverdefined
MsgBox "Mate is overdefining"
Case swFeatureErrorMateIlldefined
MsgBox "Mate cannot be solved (Ill-Defined)"
Case swFeatureErrorMateBroken
MsgBox "One or more entities suppressed or invalid for this mate"
End Select
swDoc.ClearSelection2 True
swMate.Select True
swDoc.Extension.DeleteSelection2 0
End If
swDoc.ClearSelection2 True
End Sub
Concentric mate:
CODE
Dim swDoc As SldWorks.ModelDoc2
Dim swAssy As SldWorks.AssemblyDoc
Dim swSelMgr As SldWorks.SelectionMgr
Dim swMate As SldWorks.Mate2
Dim ErrorLong As Long
Dim MsgReply As Integer
Dim NewAlign As Long
Sub main()
Set swApp = Application.SldWorks
Set swDoc = swApp.ActiveDoc
Set swAssy = swDoc
Set swSelMgr = swDoc.SelectionManager
If swDoc.GetType <> swDocASSEMBLY Then
MsgBox "Use this macro in Assembly documents only.", vbCritical
Exit Sub
End If
If swSelMgr.GetSelectedObjectCount <> 2 Then
MsgBox swSelMgr.GetSelectedObjectCount & " items selected. Req'd number is 2.", vbCritical
Exit Sub
End If
Set swMate = swAssy.AddMate3(swMateCONCENTRIC, swMateAlignCLOSEST, False, 0, 0, 0, 0, 0, 0, 0, 0, False, ErrorLong)
If Nothing Is swMate Then
MsgBox "Mating Error #" & ErrorLong & " Mate not added.", vbCritical
Exit Sub
End If
If swAddMateError_OverDefinedAssembly = ErrorLong Then
MsgReply = MsgBox("Overdefining mate. Keep anyway?", vbYesNo + vbQuestion)
If vbNo = MsgReply Then
swDoc.ClearSelection2 True
swMate.Select True
swDoc.Extension.DeleteSelection2 0
Else
'swDoc.EditRebuild3
End If
ElseIf swMate.Alignment <> swMateAlignCLOSEST Then
MsgReply = MsgBox("Keep current alignment?", vbYesNo, "Mate Alignment")
If vbNo = MsgReply Then
If swMate.Alignment = swMateAlignALIGNED Then
NewAlign = swMateAlignANTI_ALIGNED
Else
NewAlign = swMateAlignALIGNED
End If
swMate.Select True
swAssy.EditMate2 swMateCONCENTRIC, NewAlign, False, 0, 0, 0, 0, 0, 0, 0, 0, ErrorLong
If swAddMateError_OverDefinedAssembly = ErrorLong Then
MsgReply = MsgBox("Flip caused errors. Undo?", vbYesNo + vbQuestion)
If vbYes = MsgReply Then
swDoc.EditUndo2 1
End If
End If
'swDoc.EditRebuild3
End If
ElseIf swAddMateError_NoError <> ErrorLong Then
MsgBox "Mate error #" & ErrorLong & vbCrLf & "Mate not added"
If Not swMate Is Nothing Then
swDoc.ClearSelection2 True
swMate.Select True
swDoc.Extension.DeleteSelection2 0
End If
ElseIf swMate.GetErrorCode <> swFeatureErrorNone Then
Select Case swMate.GetErrorCode
Case swFeatureErrorMateInvalidEdge
MsgBox "Invalid edge"
Case swFeatureErrorMateInvalidFace
MsgBox "Invalid Face"
Case swFeatureErrorMateFailedCreatingSurface
MsgBox "Mate surface type not supported"
Case swFeatureErrorMateInvalidEntity
MsgBox "Supressed, Invalid, or Missing Entity"
Case swFeatureErrorMateDanglingGeometry
MsgBox "Mate geometry is dangling"
Case swFeatureErrorMateEntityNotLinear
MsgBox "Non-linear edges cannot be used for mating"
Case swFeatureErrorMateOverdefined
MsgBox "Mate is overdefining"
Case swFeatureErrorMateIlldefined
MsgBox "Mate cannot be solved (Ill-Defined)"
Case swFeatureErrorMateBroken
MsgBox "One or more entities suppressed or invalid for this mate"
End Select
swDoc.ClearSelection2 True
swMate.Select True
swDoc.Extension.DeleteSelection2 0
End If
swDoc.ClearSelection2 True
End Sub
Parallel mate:
CODE
Dim swDoc As SldWorks.ModelDoc2
Dim swAssy As SldWorks.AssemblyDoc
Dim swSelMgr As SldWorks.SelectionMgr
Dim swMate As SldWorks.Mate2
Dim ErrorLong As Long
Dim MsgReply As Integer
Dim NewAlign As Long
Sub main()
Set swApp = Application.SldWorks
Set swDoc = swApp.ActiveDoc
Set swAssy = swDoc
Set swSelMgr = swDoc.SelectionManager
If swDoc.GetType <> swDocASSEMBLY Then
MsgBox "Use this macro in Assembly documents only.", vbCritical
Exit Sub
End If
If swSelMgr.GetSelectedObjectCount <> 2 Then
MsgBox swSelMgr.GetSelectedObjectCount & " items selected. Req'd number is 2.", vbCritical
Exit Sub
End If
Set swMate = swAssy.AddMate3(swMatePARALLEL, swMateAlignCLOSEST, False, 0, 0, 0, 0, 0, 0, 0, 0, False, ErrorLong)
If Nothing Is swMate Then
MsgBox "Mating Error #" & ErrorLong & " Mate not added.", vbCritical
Exit Sub
End If
If swAddMateError_OverDefinedAssembly = ErrorLong Then
MsgReply = MsgBox("Overdefining mate. Keep anyway?", vbYesNo + vbQuestion)
If vbNo = MsgReply Then
swDoc.ClearSelection2 True
swMate.Select True
swDoc.Extension.DeleteSelection2 0
Else
'swDoc.EditRebuild3
End If
ElseIf swMate.Alignment <> swMateAlignCLOSEST Then
MsgReply = MsgBox("Keep current alignment?", vbYesNo, "Mate Alignment")
If vbNo = MsgReply Then
If swMate.Alignment = swMateAlignALIGNED Then
NewAlign = swMateAlignANTI_ALIGNED
Else
NewAlign = swMateAlignALIGNED
End If
swMate.Select True
swAssy.EditMate2 swMatePARALLEL, NewAlign, False, 0, 0, 0, 0, 0, 0, 0, 0, ErrorLong
If swAddMateError_OverDefinedAssembly = ErrorLong Then
MsgReply = MsgBox("Flip caused errors. Undo?", vbYesNo + vbQuestion)
If vbYes = MsgReply Then
swDoc.EditUndo2 1
End If
End If
'swDoc.EditRebuild3
End If
ElseIf swAddMateError_NoError <> ErrorLong Then
MsgBox "Mate error #" & ErrorLong & vbCrLf & "Mate not added"
If Not swMate Is Nothing Then
swDoc.ClearSelection2 True
swMate.Select True
swDoc.Extension.DeleteSelection2 0
End If
ElseIf swMate.GetErrorCode <> swFeatureErrorNone Then
Select Case swMate.GetErrorCode
Case swFeatureErrorMateInvalidEdge
MsgBox "Invalid edge"
Case swFeatureErrorMateInvalidFace
MsgBox "Invalid Face"
Case swFeatureErrorMateFailedCreatingSurface
MsgBox "Mate surface type not supported"
Case swFeatureErrorMateInvalidEntity
MsgBox "Supressed, Invalid, or Missing Entity"
Case swFeatureErrorMateDanglingGeometry
MsgBox "Mate geometry is dangling"
Case swFeatureErrorMateEntityNotLinear
MsgBox "Non-linear edges cannot be used for mating"
Case swFeatureErrorMateOverdefined
MsgBox "Mate is overdefining"
Case swFeatureErrorMateIlldefined
MsgBox "Mate cannot be solved (Ill-Defined)"
Case swFeatureErrorMateBroken
MsgBox "One or more entities suppressed or invalid for this mate"
End Select
swDoc.ClearSelection2 True
swMate.Select True
swDoc.Extension.DeleteSelection2 0
End If
swDoc.ClearSelection2 True
End Sub
RE: Plane/Origin Selection Macro