Macro to add display data marks to configuration used by the main SOLIDWORKS assembly
This VBA macro is useful for the users working with assemblies in the Large Design Review mode or when it is required to support configurations in eDrawings.
By default only active configuration is preserved for using the the Large Design Review mode and other configurations of the assembly cannot be activated:
This macro will traverse all components of the root assembly and find all the used configurations and add the display mark data to all of them.
This will allow to open all sub components in the Large Design Review mode and activate used configurations.
Dim swApp As SldWorks.SldWorks
Sub main()
Set swApp = Application.SldWorks
Dim swAssy As SldWorks.AssemblyDoc
Set swAssy = swApp.ActiveDoc
If Not swAssy Is Nothing Then
Dim vComps As Variant
vComps = CollectSelectedComponents(swAssy)
If IsEmpty(vComps) Then
vComps = swAssy.GetComponents(False)
End If
Dim files As Object
Set files = CollectFilesNeedDisplayMarks(vComps, swAssy.GetPathName)
For Each filePath In files.Keys
Dim vConfNames As Variant
vConfNames = files.item(filePath)
AddDisplayMarks CStr(filePath), vConfNames
Next
Else
Err.Raise vbError, "", "Open assembly"
End If
End Sub
Function CollectSelectedComponents(model As SldWorks.ModelDoc2) As Variant
Dim i As Integer
Dim swSelMgr As SldWorks.SelectionMgr
Set swSelMgr = model.SelectionManager
Dim swComps() As SldWorks.Component2
Dim isInit As Boolean
For i = 1 To swSelMgr.GetSelectedObjectCount2(-1)
If swSelMgr.GetSelectedObjectType3(i, -1) = swSelectType_e.swSelCOMPONENTS Then
Dim swComp As SldWorks.Component2
Set swComp = swSelMgr.GetSelectedObject6(i, -1)
If Not isInit Then
isInit = True
ReDim swComps(0)
Else
ReDim Preserve swComps(UBound(swComps) + 1)
End If
Set swComps(UBound(swComps)) = swComp
End If
Next
If isInit Then
CollectSelectedComponents = swComps
Else
CollectSelectedComponents = Empty
End If
End Function
Function CollectFilesNeedDisplayMarks(comps As Variant, rootDocPath As String) As Object
Dim files As Object
Set files = CreateObject("Scripting.Dictionary")
Dim i As Integer
For i = 0 To UBound(comps)
Dim swComp As SldWorks.Component2
Set swComp = comps(i)
Dim filePath As String
filePath = ResolveReferencePath(rootDocPath, swComp.GetPathName())
If Dir(filePath) <> "" Then
Dim refConfName As String
refConfName = swComp.ReferencedConfiguration
Dim activeConfName As String
activeConfName = swApp.GetActiveConfigurationName(swComp.GetPathName())
Dim confNames() As String
If LCase(refConfName) <> LCase(activeConfName) Then
If files.Exists(LCase(filePath)) Then
confNames = files(LCase(filePath))
If Not Contains(confNames, refConfName) Then
ReDim Preserve confNames(UBound(confNames) + 1)
confNames(UBound(confNames)) = refConfName
files(LCase(filePath)) = confNames
End If
Else
ReDim confNames(0)
confNames(0) = refConfName
files.Add LCase(filePath), confNames
End If
End If
Else
Debug.Print "Failed to resolve component " & swComp.Name2 & " path: " & filePath
End If
Next
Set CollectFilesNeedDisplayMarks = files
End Function
Function Contains(arr() As String, item As String) As Boolean
Dim i As Integer
For i = 0 To UBound(arr)
If LCase(arr(i)) = LCase(item) Then
Contains = True
Exit Function
End If
Next
Contains = False
End Function
Sub AddDisplayMarks(filePath As String, confNames As Variant)
Debug.Print "Adding display mark for " & filePath
Dim swModel As SldWorks.ModelDoc2
Dim swDocSpec As SldWorks.DocumentSpecification
Set swDocSpec = swApp.GetOpenDocSpec(filePath)
swDocSpec.LightWeight = False
swDocSpec.ViewOnly = False
swDocSpec.Silent = True
Set swModel = swApp.OpenDoc7(swDocSpec)
If Not swModel Is Nothing Then
Set swModel = swApp.ActivateDoc3(swModel.GetTitle(), False, swRebuildOnActivation_e.swDontRebuildActiveDoc, -1)
If Not swModel Is Nothing Then
Dim i As Integer
For i = 0 To UBound(confNames)
Dim swConf As SldWorks.Configuration
Set swConf = swModel.GetConfigurationByName(CStr(confNames(i)))
swConf.LargeDesignReviewMark = True
Next
swModel.ForceRebuild3 False
swModel.Save3 swSaveAsOptions_e.swSaveAsOptions_Silent, 0, 0
swApp.CloseDoc swModel.GetTitle
Else
Debug.Print "Failed to activate document: " & filePath
End If
Else
Debug.Print "Failed to open document: " & filePath
End If
End Sub
Function ResolveReferencePath(rootDocPath As String, refPath As String) As String
Dim pathParts As Variant
pathParts = Split(refPath, "\")
Dim rootFolder As String
rootFolder = rootDocPath
rootFolder = Left(rootFolder, InStrRev(rootFolder, "\") - 1)
Dim i As Integer
Dim curRelPath As String
For i = UBound(pathParts) To 1 Step -1
curRelPath = pathParts(i) & IIf(curRelPath <> "", "\", "") & curRelPath
Dim path As String
path = rootFolder & "\" & curRelPath
If Dir(path) <> "" Then
ResolveReferencePath = path
Exit Function
End If
Next
ResolveReferencePath = refPath
End Function
Alternative version of the macro will only process configurations of the active part or assembly and add the Display Data marks
Dim swApp As SldWorks.SldWorks
Sub main()
Set swApp = Application.SldWorks
Dim swModel As SldWorks.ModelDoc2
Set swModel = swApp.ActiveDoc
If Not swModel Is Nothing Then
If swModel.GetType() = swDocumentTypes_e.swDocASSEMBLY Or swModel.GetType() = swDocumentTypes_e.swDocPART Then
Dim vConfNames As Variant
vConfNames = swModel.GetConfigurationNames
Dim i As Integer
For i = 0 To UBound(vConfNames)
Dim swConf As SldWorks.Configuration
Set swConf = swModel.GetConfigurationByName(CStr(vConfNames(i)))
swConf.LargeDesignReviewMark = True
Next
swModel.ForceRebuild3 False
Else
Err.Raise vbError, "", "Only assemblies and parts are supported"
End If
Else
Err.Raise vbError, "", "No files opened"
End If
End Sub