Here's a modification... in the previous macro, changing that constant only changes which geometry gets selected first. If reference geometry is already selected, it will still cycle through the features as before rather than going directly to the one specified by FIRSTREF.
Here's one that will only select the geometry specified. It's one macro with four methods. When you assign the macro to a button, you need to select the starting method (SelFront, SelTop, etc). You can make four different buttons, each with a different method. They'll all call the same selection code, they just pick different geometry. You don't need to make four copies of the macro, just four buttons. Or 3 if you just want the planes. Or however many buttons you want.
'-------------------------------------------------
' 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.
' Postconditions: One of the reference planes or the
' origin of the last selected component is selected.
' Or, if nothing was selected, reference geometry of the
' top level assembly.
' Change the constant below to specify which piece of ref geometry to select
'--------------------------------------------------
'''''''''
Option Explicit
Sub SelFront()
makeSel 1
End Sub
Sub SelTop()
makeSel 2
End Sub
Sub SelRight()
makeSel 3
End Sub
Sub SelOrigin()
makeSel 4
End Sub
Sub makeSel(FirstRef As Long)
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
'This next block of code just gets the component for whatever was las selected (if one is selected)
'and checks to see if it's suppressed, or if it's lightweight in SW<2006
Set swSelMgr = swModel.SelectionManager
CurSelCount = swSelMgr.GetSelectedObjectCount
If CurSelCount <> 0 Then
Set GeneralSelObj = swSelMgr.GetSelectedObject(CurSelCount)
Set swSelComp = swSelMgr.GetSelectedObjectsComponent(CurSelCount)
If Not swSelComp Is Nothing Then
If swSelComp.GetSuppression = swComponentSuppressed Then
MsgBox "Can't get to reference geometry of a suppressed component."
Exit Sub
End If
End If
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
End If
'If swSelComp is nothing, that means nothing was selected when the macro was run, therefore we
'need to get the geometry of the top level assembly. Then we get the first feature of
'either top level or the selected component for iteration.
If swSelComp Is Nothing Then
Set swSelComp = swModel.ConfigurationManager.ActiveConfiguration.GetRootComponent3(False)
Set swFeat = swModel.FirstFeature
Else
Set swFeat = swSelComp.FirstFeature
End If
'Now we iterate through the features of the component. If the feature is a plane,
'and it's not suppressed, we add it to a Collection. Not selecting anything now,
'just reading the feature tree.
Do While Not swFeat Is Nothing
If ("RefPlane" = swFeat.GetTypeName) And (False = swFeat.IsSuppressed) Then
myFeatureCollection.Add swFeat
End If
'This sort of messy "If" block is what we have to do in order to select the origin in an
'appropriate way for mating. It's just added to the collection.
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
'This was the origin, which is assumed to always follow the 3 standard planes. Stop traversing the tree.
Exit Do
End If
Set swFeat = swFeat.GetNextFeature
Loop
'At this point (assuming that STOPATORIGIN was left as "true"), we should have a
'Collection containing 4 items: the three main planes and the origin.
'Now we just CHOOSE the one that we PLAN to select. Just to avoid weird errors in case the
'collection didn't get loaded right,
'we choose Item #1 to start, but then we go ahead and try to choose the one we wanted
'per the constant up at the top of the code. If that "choosing" fails, #1 remains "chosen"
If NewObjToSelect Is Nothing Then
Set NewObjToSelect = myFeatureCollection.Item(1)
On Error Resume Next
Set NewObjToSelect = myFeatureCollection.Item(FirstRef)
On Error GoTo 0
End If
'This is the line that actually selects the item we chose from the collection.
bRet = NewObjToSelect.Select(True): Debug.Assert bRet
End Sub
'-------------------------------------------------
Aug 3, 2018 8:39 AM
