Open all selected components in positions in new windows
This VBA macro opens all selected components in the active assembly in their own windows in the same position as they appear in the original SOLIDWORKS assembly.
This macro emulates the Open Part In Position command in SOLIDWORKS toolbar, but allows to open multiple selected components at the same time.
{ width=250 }
Dim swApp As SldWorks.SldWorks
Sub main()
Set swApp = Application.SldWorks
Dim swAssy As SldWorks.AssemblyDoc
Set swAssy = swApp.ActiveDoc
try:
On Error GoTo catch
If Not swAssy Is Nothing Then
Dim swSelMgr As SldWorks.SelectionMgr
Set swSelMgr = swAssy.SelectionManager
Dim i As Integer
Dim hasCompSel As Boolean
hasCompSel = False
For i = 1 To swSelMgr.GetSelectedObjectCount2(-1)
Dim swComp As SldWorks.Component2
Set swComp = swSelMgr.GetSelectedObjectsComponent3(i, -1)
If Not swComp Is Nothing Then
hasCompSel = True
Dim swCompTransform As SldWorks.MathTransform
Dim swViewTransform As SldWorks.MathTransform
Dim swTotalTransform As SldWorks.MathTransform
Set swCompTransform = swComp.Transform2
Set swViewTransform = swAssy.ActiveView.Orientation3
Set swTotalTransform = swCompTransform.Multiply(swViewTransform)
OpenComponentWithTransforms swComp, swTotalTransform
End If
Next
If Not hasCompSel Then
Err.Raise vbError, , "No components selected"
End If
Else
Err.Raise vbError, , "Please open assembly"
End If
GoTo finally
catch:
swApp.SendMsgToUser2 Err.Description, swMessageBoxIcon_e.swMbStop, swMessageBoxBtn_e.swMbOk
finally:
End Sub
Sub OpenComponentWithTransforms(comp As SldWorks.Component2, transform As SldWorks.MathTransform)
Dim swRefModel As SldWorks.ModelDoc2
Dim swDocSpec As SldWorks.DocumentSpecification
Set swDocSpec = swApp.GetOpenDocSpec(comp.GetPathName())
swDocSpec.Silent = True
Set swRefModel = swApp.OpenDoc7(swDocSpec)
Dim errs As Long
Dim warns As Long
If Not swRefModel Is Nothing Then
If Not swApp.ActiveDoc Is swRefModel Then
Set swRefModel = swApp.ActivateDoc3(swRefModel.GetTitle(), False, swRebuildOnActivation_e.swUserDecision, errs)
If swRefModel Is Nothing Then
Err.Raise vbError, , "Cannot activate the referenced document. Error code:" & errs
End If
End If
Dim swView As SldWorks.ModelView
Set swView = swRefModel.ActiveView
swView.Orientation3 = transform
swRefModel.ViewZoomtofit2
Else
Err.Raise vbError, , "Cannot open the referenced document. Error code:" & swDocSpec.Error
End If
End Sub