Save weldment as assembly macro

[Wasermelone]

Hi everyone, I'm trying to write a macro that would save part that is made from weldments as an assembly. I'm trying to use the CreateSaveBodyFeature method but can't get it to work, it seems that I don't fully understand how this method works. Maybe someone knows a better solution on how to achieve this? Any help would be nice and greatly appreciated!

[ajberinguela]

Hi, I'm looking for the same thing, do you have any updates on this one? Thank you in advance

[gupta9665]

Did you looked at this example https://help.solidworks.com/2022/englis ... ple_VB.htm

[ajberinguela]

Thanks Gupta, this is close enough. However, there are still isssues I need to address.
-It works for solid bodies but not for the cut list.
-I want to use the Cut List folder name as the file name
-I want to maintain the color that is set during the creation of the part.

[gupta9665]

Thanks Gupta, this is close enough. However, there are still isssues I need to address.
-It works for solid bodies but not for the cut list.
-I want to use the Cut List folder name as the file name
-I want to maintain the color that is set during the creation of the part.

You may check this post for macro to cover 1 and 2 https://r1132100503382-eu1-3dswym.3dexp ... 7kcoePa9GQ

Unfortunately color option is not yet supported by API. So raise Enhancement Request (ER) for it.

[ajberinguela]

Thanks! This is a big help. If the API doesn’t support colors, do you have any workaround ideas?

[gupta9665]

You can try getting the color for each body into an array. And once bodies are exported as parts, you can reapply the colors to them with values from the array.

[ajberinguela]

Thank you, this is a macro that let's me saved the colors into an array. The next one is a macro I get from CodeStack that let's me put colors in part in random. Is there a way I can combine these two?


Option Explicit

Sub GetBodyColors()
Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Dim swPart As SldWorks.PartDoc
Dim swBody As SldWorks.Body2
Dim vBodies As Variant
Dim vMatProp As Variant
Dim i As Integer
Dim bodyColors() As String

Set swApp = Application.SldWorks
Set swModel = swApp.ActiveDoc
Set swPart = swModel

' Get all bodies in the part
vBodies = swPart.GetBodies2(swAllBodies, False)

' Resize the array to hold the colors
ReDim bodyColors(UBound(vBodies))

' Loop through each body and get its color
For i = 0 To UBound(vBodies)
Set swBody = vBodies(i)
vMatProp = swBody.MaterialPropertyValues2

If Not IsEmpty(vMatProp) Then
bodyColors(i) = "RGB(" & vMatProp(0) * 255 & ", " & vMatProp(1) * 255 & ", " & vMatProp(2) * 255 & ")"
Else
bodyColors(i) = "No color"
End If
Next i

' Show a message box indicating that the colors have been stored
MsgBox "Colors stored in array"
End Sub
______________________________________________________________________________________

'**********************
'Copyright(C) 2024 Xarial Pty Limited
'Reference: https://www.codestack.net/solidworks-ap ... -assembly/
'License: https://www.codestack.net/license/
'**********************
Const COMP_LEVEL As Boolean = False
Const PARTS_ONLY As Boolean = False
Const ALL_CONFIGS As Boolean = False
Const PRP_NAME As String = ""
Dim swApp As SldWorks.SldWorks
Dim ColorsMap As Object
Sub InitColors(Optional dummy As Variant = Empty)
ColorsMap.Add "Plate", RGB(255, 0, 0)
ColorsMap.Add "Beam", RGB(0, 255, 0)

End Sub
Sub main()
try_:

On Error GoTo catch_

Set ColorsMap = CreateObject("Scripting.Dictionary")
ColorsMap.CompareMode = vbTextCompare
InitColors
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 Then

Dim swAssy As SldWorks.AssemblyDoc

Set swAssy = swModel

swAssy.ResolveAllLightWeightComponents True

Dim vComps As Variant
vComps = swAssy.GetComponents(False)

ColorizeComponents vComps

swModel.GraphicsRedraw2
Else
Err.Raise vbError, "", "Only assembly document is supported"
End If
Else
Err.Raise vbError, "", "Open assembly document"
End If

GoTo finally_

catch_:
MsgBox Err.Description, vbCritical
finally_:

End Sub
Sub ColorizeComponents(vComps As Variant)

Dim i As Integer

Dim processedDocs() As String

For i = 0 To UBound(vComps)

Dim swComp As SldWorks.Component2
Set swComp = vComps(i)

Dim swRefModel As SldWorks.ModelDoc2

Set swRefModel = swComp.GetModelDoc2()

If Not swRefModel Is Nothing Then

If Not PARTS_ONLY Or swRefModel.GetType() = swDocumentTypes_e.swDocPART Then

Dim docKey As String
docKey = LCase(swRefModel.GetPathName())

If Not ALL_CONFIGS Then
docKey = docKey & ":" & LCase(swComp.ReferencedConfiguration)
End If

If COMP_LEVEL Or Not Contains(processedDocs, docKey) Then

If (Not processedDocs) = -1 Then
ReDim processedDocs(0)
Else
ReDim Preserve processedDocs(UBound(processedDocs) + 1)
End If

processedDocs(UBound(processedDocs)) = docKey

Dim color As Long
color = RGB(Int(255 * Rnd), Int(255 * Rnd), Int(255 * Rnd))

If PRP_NAME <> "" Then

Dim prpVal As String

prpVal = GetModelPropertyValue(swRefModel, swComp.ReferencedConfiguration, PRP_NAME)

If prpVal <> "" Then

If ColorsMap.Exists(prpVal) Then
color = ColorsMap(prpVal)
Else
ColorsMap.Add prpVal, color
End If

End If

End If

Dim RGBHex As String

RGBHex = Right("000000" & Hex(color), 6)

Dim dMatPrps(8) As Double

dMatPrps(0) = CInt("&H" & Mid(RGBHex, 5, 2)) / 255
dMatPrps(1) = CInt("&H" & Mid(RGBHex, 3, 2)) / 255
dMatPrps(2) = CInt("&H" & Mid(RGBHex, 1, 2)) / 255
dMatPrps(3) = 1
dMatPrps(4) = 1
dMatPrps(5) = 0.5
dMatPrps(6) = 0.3125
dMatPrps(7) = 0
dMatPrps(8) = 0

If COMP_LEVEL Then
swComp.SetMaterialPropertyValues2 dMatPrps, IIf(ALL_CONFIGS, swInConfigurationOpts_e.swAllConfiguration, swInConfigurationOpts_e.swThisConfiguration), Empty
Else
Dim sConfs(0) As String
sConfs(0) = swComp.ReferencedConfiguration
swRefModel.Extension.SetMaterialPropertyValues dMatPrps, IIf(ALL_CONFIGS, swInConfigurationOpts_e.swAllConfiguration, swInConfigurationOpts_e.swSpecifyConfiguration), IIf(ALL_CONFIGS, Empty, sConfs)
swRefModel.SetSaveFlag
End If

End If

End If

End If

Next

End Sub
Function GetModelPropertyValue(model As SldWorks.ModelDoc2, confName As String, prpName As String) As String

Dim prpVal As String
Dim swCustPrpMgr As SldWorks.CustomPropertyManager

Set swCustPrpMgr = model.Extension.CustomPropertyManager(confName)
prpVal = GetPropertyValue(swCustPrpMgr, prpName)

If prpVal = "" Then
Set swCustPrpMgr = model.Extension.CustomPropertyManager("")
prpVal = GetPropertyValue(swCustPrpMgr, prpName)
End If

GetModelPropertyValue = prpVal

End Function
Function GetPropertyValue(custPrpMgr As SldWorks.CustomPropertyManager, prpName As String) As String
Dim resVal As String
custPrpMgr.Get2 prpName, "", resVal
GetPropertyValue = resVal
End Function
Function Contains(arr() As String, item As String) As Boolean

If (Not arr) <> -1 Then

Dim i As Integer

For i = 0 To UBound(arr)
If arr(i) = item Then
Contains = True
Exit Function
End If
Next

End If

Contains = False

End Function