From 4871ae0daf1893803fe6fc3e03d5d1194ed5fee3 Mon Sep 17 00:00:00 2001 From: Artem Date: Wed, 9 Aug 2023 22:33:13 +1000 Subject: [PATCH 1/2] Added the reload sheet for the replace sheet format macro Added alternative macro to assign sketch color (on a line color level) --- .../drawing/replace-sheet-format/Macro.vba | 6 +- .../assign-random-color/SetLineColorMacro.vba | 128 ++++++++++++++++++ .../sketch/assign-random-color/index.md | 12 +- 3 files changed, 144 insertions(+), 2 deletions(-) create mode 100644 solidworks-api/document/sketch/assign-random-color/SetLineColorMacro.vba diff --git a/solidworks-api/document/drawing/replace-sheet-format/Macro.vba b/solidworks-api/document/drawing/replace-sheet-format/Macro.vba index 43931d28..4c36023c 100644 --- a/solidworks-api/document/drawing/replace-sheet-format/Macro.vba +++ b/solidworks-api/document/drawing/replace-sheet-format/Macro.vba @@ -123,7 +123,11 @@ Sub ReplaceSheetFormat(draw As SldWorks.DrawingDoc, sheet As SldWorks.sheet, tar height = CDbl(vProps(6)) custPrpView = sheet.CustomPropertyView - If False = draw.SetupSheet5(sheet.GetName(), paperSize, templateType, scale1, scale2, firstAngle, targetSheetFormatFile, width, height, custPrpView, REMOVE_MODIFIED_NOTES) Then + If False <> draw.SetupSheet5(sheet.GetName(), paperSize, templateType, scale1, scale2, firstAngle, targetSheetFormatFile, width, height, custPrpView, REMOVE_MODIFIED_NOTES) Then + If sheet.ReloadTemplate(Not REMOVE_MODIFIED_NOTES) <> swReloadTemplateResult_e.swReloadTemplate_Success Then + Err.Raise vbError, "", "Failed to reload sheet format" + End If + Else Err.Raise vbError, "", "Failed to set the sheet format" End If diff --git a/solidworks-api/document/sketch/assign-random-color/SetLineColorMacro.vba b/solidworks-api/document/sketch/assign-random-color/SetLineColorMacro.vba new file mode 100644 index 00000000..7d086b04 --- /dev/null +++ b/solidworks-api/document/sketch/assign-random-color/SetLineColorMacro.vba @@ -0,0 +1,128 @@ +Const UNUBSORBED_ONLY As Boolean = True + +Dim swApp As SldWorks.SldWorks +Dim swModel As SldWorks.ModelDoc2 +Dim swPart As SldWorks.PartDoc + +Sub main() + + Set swApp = Application.SldWorks + + Set swModel = swApp.ActiveDoc + + Set swPart = swModel + + Dim vFeats As Variant + + vFeats = CollectSelectedSketches(swModel) + + If IsEmpty(vFeats) Then + vFeats = CollectAllSketchFeatures(swModel.FirstFeature) + End If + + If Not IsEmpty(vFeats) Then + + Dim i As Integer + + For i = 0 To UBound(vFeats) + + Dim swFeat As SldWorks.Feature + Set swFeat = vFeats(i) + + If False <> swFeat.Select2(False, -1) Then + swPart.SetLineColor RGB(CInt(255 * Rnd()), CInt(255 * Rnd()), CInt(255 * Rnd())) + Else + Err.Raise vbError, "", "Failed to select " & swFeat.Name + End If + + Next + + End If + + swModel.ClearSelection2 True + +End Sub + +Function IsAbsorbed(feat As SldWorks.Feature) As Boolean + + Dim vFeatChildren As Variant + vFeatChildren = feat.GetChildren() + + IsAbsorbed = Not IsEmpty(vFeatChildren) + +End Function + +Function CollectSelectedSketches(model As SldWorks.ModelDoc2) As Variant + + Dim swFeats() As SldWorks.Feature + + Dim swSelMgr As SldWorks.SelectionMgr + + Set swSelMgr = model.SelectionManager + + Dim i As Integer + + For i = 1 To swSelMgr.GetSelectedObjectCount2(-1) + + If swSelMgr.GetSelectedObjectType3(i, -1) = swSelectType_e.swSelSKETCHES Then + + If (Not swFeats) = -1 Then + ReDim swFeats(0) + Else + ReDim Preserve swFeats(UBound(swFeats) + 1) + End If + + Set swFeats(UBound(swFeats)) = swSelMgr.GetSelectedObject6(i, -1) + + End If + + Next + + If (Not swFeats) = -1 Then + CollectSelectedSketches = Empty + Else + CollectSelectedSketches = swFeats + End If + +End Function + +Function CollectAllSketchFeatures(firstFeat As SldWorks.Feature) As Variant + + Const SKETCH_FEAT_TYPE_NAME As String = "ProfileFeature" + Const SKETCH_3D_FEAT_TYPE_NAME As String = "3DProfileFeature" + + Dim swFeats() As SldWorks.Feature + + Dim swFeat As SldWorks.Feature + Set swFeat = firstFeat + + While Not swFeat Is Nothing + + If swFeat.GetTypeName2 = SKETCH_FEAT_TYPE_NAME Or _ + swFeat.GetTypeName2 = SKETCH_3D_FEAT_TYPE_NAME Then + + If Not UNUBSORBED_ONLY Or Not IsAbsorbed(swFeat) Then + + If (Not swFeats) = -1 Then + ReDim swFeats(0) + Else + ReDim Preserve swFeats(UBound(swFeats) + 1) + End If + + Set swFeats(UBound(swFeats)) = swFeat + + End If + + End If + + Set swFeat = swFeat.GetNextFeature + + Wend + + If (Not swFeats) = -1 Then + CollectAllSketchFeatures = Empty + Else + CollectAllSketchFeatures = swFeats + End If + +End Function \ No newline at end of file diff --git a/solidworks-api/document/sketch/assign-random-color/index.md b/solidworks-api/document/sketch/assign-random-color/index.md index 415886ce..6a4cf153 100644 --- a/solidworks-api/document/sketch/assign-random-color/index.md +++ b/solidworks-api/document/sketch/assign-random-color/index.md @@ -13,4 +13,14 @@ Const SKIP_ASSIGNED As Boolean = False 'Processes all sketches (including the sk Const UNABSORBED_ONLY As Boolean = False 'Process all sketches (absorbed and unabsorbed) ~~~ -{% code-snippet { file-name: Macro.vba } %} \ No newline at end of file +Color will be assigned on the feature appearance level. + +{% code-snippet { file-name: Macro.vba } %} + +## Line Colors + +This is an alternative version of the macro which assigns the color as a line color instead of the feature appearance. + +This macro will assign the random color for all selected sketches or all sketches if no sketches are selected. **UNABSORBED_ONLY** option is only considered when no sketches are selected. + +{% code-snippet { file-name: SetLineColorMacro.vba } %} \ No newline at end of file From cac4262c2f87a52cbf0ffc7015b3a33ec0d5d81f Mon Sep 17 00:00:00 2001 From: Artem Date: Fri, 25 Aug 2023 15:52:00 +1000 Subject: [PATCH 2/2] Added the macro to apply random colors to the components in the assembly Modified clear colors macro to remove form the model level as well --- .../appearance/color-assembly/Macro.vba | 196 ++++++++++++++++++ .../appearance/color-assembly/index.md | 29 +++ .../appearance/remove-color/Macro.vba | 44 ++-- .../document/appearance/remove-color/index.md | 6 +- 4 files changed, 254 insertions(+), 21 deletions(-) create mode 100644 solidworks-api/document/appearance/color-assembly/Macro.vba create mode 100644 solidworks-api/document/appearance/color-assembly/index.md diff --git a/solidworks-api/document/appearance/color-assembly/Macro.vba b/solidworks-api/document/appearance/color-assembly/Macro.vba new file mode 100644 index 00000000..94775dec --- /dev/null +++ b/solidworks-api/document/appearance/color-assembly/Macro.vba @@ -0,0 +1,196 @@ +Const COMP_LEVEL As Boolean = True +Const PARTS_ONLY As Boolean = True +Const ALL_CONFIGS As Boolean = True +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) + 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 \ No newline at end of file diff --git a/solidworks-api/document/appearance/color-assembly/index.md b/solidworks-api/document/appearance/color-assembly/index.md new file mode 100644 index 00000000..6bfbcb50 --- /dev/null +++ b/solidworks-api/document/appearance/color-assembly/index.md @@ -0,0 +1,29 @@ +--- +caption: Apply Random Colors To Components +title: Macro to apply random colors to components in SOLIDWORKS assembly +description: VBA macro to apply random color to all components in the SOLIDWORKS assembly with an option to apply on a component or model level and group by custom property value +--- +This VBA macro applies a random color on all components of the active assembly. + +Modify constants of the macro to change the level of the color (component or model level). + +If colors is applied to the individual configurations (e.g. **ALL_CONFIGS** = **False**), documents must have a display state linked to the configuration, otherwise the color cannot be configuration specific + +~~~ vb +Const COMP_LEVEL As Boolean = True 'True to apply color on the assembly level, False to apply color on a model level +Const PARTS_ONLY As Boolean = True 'True to only process part components, False to apply color to assemblies as well +Const ALL_CONFIGS As Boolean = True 'True to apply color to all configurations, False to apply to referenced configuration only +~~~ + +~~~ vb +Const PRP_NAME As String = "Type" 'Custom property to group color by, Empty string "" to not group components + +Sub InitColors(Optional dummy As Variant = Empty) + + ColorsMap.Add "Plate", RGB(255, 0, 0) 'Color all component which custom property 'Type' equals to 'Plate' to Red color + ColorsMap.Add "Beam", RGB(0, 255, 0) 'Color all component which custom property 'Type' equals to 'Beam' to Green color + +End Sub +~~~ + +{% code-snippet { file-name: Macro.vba } %} \ No newline at end of file diff --git a/solidworks-api/document/appearance/remove-color/Macro.vba b/solidworks-api/document/appearance/remove-color/Macro.vba index 870062ef..bfcc4f41 100644 --- a/solidworks-api/document/appearance/remove-color/Macro.vba +++ b/solidworks-api/document/appearance/remove-color/Macro.vba @@ -6,23 +6,38 @@ Sub main() Set swApp = Application.SldWorks - Dim swPart As SldWorks.PartDoc + Dim swModel As SldWorks.ModelDoc2 - Set swPart = GetActivePart(swApp) + Set swModel = swApp.ActiveDoc - If Not swPart Is Nothing Then + If Not swModel Is Nothing Then + + If swModel.GetType() = swDocumentTypes_e.swDocDRAWING Then + Err.Raise vbError, "", "Drawings are not supported" + End If Dim configOpts As swInConfigurationOpts_e configOpts = GetConfigurationOptions(REMOVE_FROM_ALL_CONFIGS) - Dim vBodies As Variant - vBodies = swPart.GetBodies2(swBodyType_e.swAllBodies, False) + If swModel.GetType() = swDocumentTypes_e.swDocPART Then + + Dim swPart As SldWorks.PartDoc + Set swPart = swModel + + Dim vBodies As Variant + vBodies = swPart.GetBodies2(swBodyType_e.swAllBodies, False) + + RemoveMaterialPropertiesFromBodies vBodies, True, configOpts + RemoveMaterialPropertiesFromFeatures swPart.FeatureManager.GetFeatures(False), configOpts + + End If + + swModel.Extension.RemoveMaterialProperty configOpts, Empty - RemoveMaterialPropertiesFromBodies vBodies, True, configOpts - RemoveMaterialPropertiesFromFeatures swPart.FeatureManager.GetFeatures(False), configOpts + swModel.GraphicsRedraw2 Else - MsgBox "Please open part document" + Err.Raise "Please open part or assembly document" End If End Sub @@ -82,6 +97,7 @@ Sub RemoveMaterialPropertiesFromFeatures(features As Variant, configOpts As swIn Dim swFeat As SldWorks.Feature Set swFeat = features(i) + Debug.Print swFeat.Name swFeat.RemoveMaterialProperty2 configOpts, Empty Next @@ -89,20 +105,12 @@ Sub RemoveMaterialPropertiesFromFeatures(features As Variant, configOpts As swIn End If End Sub -Function GetActivePart(app As SldWorks.SldWorks) As SldWorks.PartDoc - - On Error Resume Next - - Set GetActivePart = app.ActiveDoc - -End Function - Function GetConfigurationOptions(allConfigs As Boolean) As swInConfigurationOpts_e If REMOVE_FROM_ALL_CONFIGS Then - GetConfigurationOptions = swAllConfiguration + GetConfigurationOptions = swInConfigurationOpts_e.swAllConfiguration Else - GetConfigurationOptions = swThisConfiguration + GetConfigurationOptions = swInConfigurationOpts_e.swThisConfiguration End If End Function \ No newline at end of file diff --git a/solidworks-api/document/appearance/remove-color/index.md b/solidworks-api/document/appearance/remove-color/index.md index f888aa71..8dd176c3 100644 --- a/solidworks-api/document/appearance/remove-color/index.md +++ b/solidworks-api/document/appearance/remove-color/index.md @@ -1,15 +1,15 @@ --- layout: sw-tool -title: Macro to remove all colors from SOLIDWORKS part +title: Macro to remove all colors from SOLIDWORKS document caption: Remove All Colors From Part -description: Macro demonstrates how to remove all colors from the part document on all levels (face, feature, body) using SOLIDWORKS API +description: Macro demonstrates how to remove all colors from the part or assembly documents on all levels (face, feature, body, model) using SOLIDWORKS API image: remove-colors.svg labels: [remove color, appearance, material property] group: Part --- ![Appearance layers in Part document](material-properties-levels.png){ width=250 } -This macro removes all colors from the part document on all levels (face, feature, body) using SOLIDWORKS API. +This macro removes all colors from the part document on all levels (face, feature, body, model) using SOLIDWORKS API. Macro can be configured to remove the colors from all configurations or active configuration only. This option can be set by changing the value of the following constant at the beginning of the macro: