Automating creation of weldment and changing colors of bodies 1

[roldy]

I'm stuck on a coding project for work. The task is to create cylinders along each segment of a line in the 3d Sketch. Each body will be colored based off of some values in a table, which I don't have right now, so I am instead trying to assign a color.

First problem is that I can't get the InsertStructuralWeldment to create the weldment. I can't see what I am doing wrong with this. I tried adapting the code from the help file.

Second problem is assigning a color to a body. I can see what the materialpropertiesvalues2 of a body are but I can't figure out how to assign a color to this body. I created an array of values for R, G, B, Ambient, Diffuse, Specularity, Shininess, Transparency, and Emission. I then tried to use swBody.MaterialPropertyValues = materialProp, where materialProp is my array of property values. I did a graphics redraw and the body color didn't change.

In the zip file, I included the Excel table from which the macro reads the starting point of the first line segment and then creates successive lines based off the angle and the length in each row of the table. I've also included the custom weldment profile I will be using which the macro calls for. The reason why I'm using a weldment to create these solids is because it allows me to create all the solids in one pass instead of having to create a plane on each endpoint of a line segment and then extruded my profile up to the next endpoint.

To run, extract the "testing" folder to C: and open up the empty "test.SLDPRT" file. Make sure that Excel is not open when running the macro.

I'm using SolidWorks 2021 SP3.

 

[fifiririloulou]

Try this:

Option Explicit
Sub main()
    Dim swApp As SldWorks.SldWorks
    Dim swModel As SldWorks.ModelDoc2
    Dim swSketch As SldWorks.Sketch
    Set swApp = Application.SldWorks
    Set swModel = swApp.ActiveDoc

    Set swSketch = CreateSketch(swModel)
    CreateWeldment swModel, swSketch
    ApplyColor swModel
End Sub

Function CreateSketch(swModel As SldWorks.ModelDoc2) As SldWorks.Sketch
    Dim xlApp As Excel.Application
    Dim xlWB As Excel.Workbook
    Dim xlSH As Excel.Worksheet
    Dim swSketchMgr As SldWorks.SketchManager
    Dim swSketch As SldWorks.Sketch
    Dim i As Integer
    Dim x1, y1, z1, x2, y2, z2 As Double
    Dim deltaX As Double
    Dim deltaZ As Double
    Dim ToRad As Double
    ToRad = 3.14159 / 180
    
On Error GoTo xls
    Set xlApp = GetObject(, "Excel.Application")
xls:
    If xlApp Is Nothing Then Set xlApp = New Excel.Application
    xlApp.Visible = False
    
    Set xlWB = xlApp.Workbooks.Open("C:\testing\Spiles\CreateSpiles.xls")
    Set xlSH = xlWB.Worksheets(1)
        
    Set swSketchMgr = swModel.SketchManager
    
    swSketchMgr.Insert3DSketch True
    Set swSketch = swSketchMgr.ActiveSketch
    
    For i = 2 To xlSH.Cells(xlSH.Rows.Count, 1).End(xlUp).Row - 1
        If i = 2 Then
            x1 = xlSH.Cells(i, 6).Value
            y1 = xlSH.Cells(i, 7).Value
            z1 = xlSH.Cells(i, 8).Value
        Else
            x1 = x2
            y1 = y2
            z1 = z2
        End If
        
        deltaX = xlSH.Cells(i + 1, 2).Value * Sin(xlSH.Cells(i + 1, 3).Value * ToRad)
        deltaZ = xlSH.Cells(i + 1, 2).Value * Cos(xlSH.Cells(i + 1, 3).Value * ToRad)
            
        x2 = x1 + deltaX
        y2 = y1
        z2 = z1 + deltaZ
    
        swModel.CreateLine2 x1, y1, z1, x2, y2, z2
    Next
    
    swSketchMgr.Insert3DSketch True
    
    xlApp.Visible = True
    xlWB.Close
    xlApp.Quit
    Set xlSH = Nothing
    Set xlWB = Nothing
    Set xlApp = Nothing
    
    Set CreateSketch = swSketch
End Function

Sub CreateWeldment(swModel As SldWorks.ModelDoc2, swSketch As SldWorks.Sketch)
    Dim swPart As SldWorks.PartDoc
    Dim swFeatMgr As SldWorks.FeatureManager
    Dim swStrucGroup As SldWorks.StructuralMemberGroup
    Dim vGroup(0) As Object
    Dim vSkSeg As Variant
    Dim vSkSegs As Variant
    Dim swSkSeg As SldWorks.SketchSegment
    Dim swFeat As SldWorks.Feature
    Dim ProfilePath As String
        
    Set swFeatMgr = swModel.FeatureManager
    Set swPart = swModel
    If swPart.IsWeldment = False Then swFeatMgr.InsertWeldmentFeature

    vSkSegs = swSketch.GetSketchSegments
    
    Set swStrucGroup = swFeatMgr.CreateStructuralMemberGroup
    
    swStrucGroup.Segments = vSkSegs
    swStrucGroup.ApplyCornerTreatment = True
    swStrucGroup.CornerTreatmentType = 1
    swStrucGroup.Angle = 0
    Set vGroup(0) = swStrucGroup
    
    ProfilePath = "C:\testing\Spiles\spileprofile.SLDLFP"
    swFeatMgr.InsertStructuralWeldment5 ProfilePath, swConnectedSegmentsOption_e.swConnectedSegments_SimpleCut, False, vGroup, Empty

End Sub

Sub ApplyColor(swModel As SldWorks.ModelDoc2)
    Dim swBody As SldWorks.Body2
    Dim vBody As Variant
    Dim vBodies As Variant
    Dim vProp2(8) As Variant
    Dim vProp As Variant
    
    vBodies = swModel.GetBodies2(swBodyType_e.swSolidBody, True)
    
    For Each vBody In vBodies
        Set swBody = vBody
        
        swBody.MaterialPropertyValues2 = vProp2
        vProp = swBody.MaterialPropertyValues2

        vProp(0) = 1 'Val("&H" + Mid(MyColor, 5, 2)) / 255  'red
        vProp(1) = 0 'Val("&H" + Mid(MyColor, 3, 2)) / 255  'green
        vProp(2) = 0 'Val("&H" + Mid(MyColor, 1, 2)) / 255  'blue
        vProp(3) = 1         'Ambient
        vProp(4) = 1         'Diffuse
        vProp(5) = 0.5       'Specularity
        vProp(6) = 0.3125    'Shininess
        vProp(7) = 0         'Transparency
        vProp(8) = 0         'Emission
        swBody.MaterialPropertyValues2 = vProp
    Next
End Sub

 

[roldy]

That worked perfectly. Thank you very much. I know my code was a bit sloppy to look at. I had intended to place the lines of code that worked together into subs once I was finished. You saved me time doing that, thank you again.

 

[roldy]

I do have one other problem that I have been trying to figure out. One of the additions I made was to turn off automatic cutlist creation and moved the bodies into a folder having the same name as the Worksheet name. If I have multiple Worksheets for multiple spiles, I'm able to go through them and create separate sketches and weldments for each sheet. When all said is done, I should have multiple folders that contain the bodies that correspond to each set of Worksheet data. When it comes to coloring, since I'm doing a swModel.GetBodies2, how do I not get the bodies that I've already colored and moved into a created folder? If I have 100 spiles each containing 100 bodies, I wouldn't want to loop through all 10,000 bodies and determine if a color has been changed or if it is already in a folder. Is there a more streamlined approach to this?

 

[fifiririloulou]

To move the bodies to a cut list folder, you can use MoveToFolder

For the color, the best way would be to apply the color to the Structural Member Feature:

Sub ApplyColor(swModel As SldWorks.ModelDoc2)
    Dim vProp As Variant
    Dim swFeat As SldWorks.Feature
    Set swFeat = swModel.Extension.GetLastFeatureAdded
    vProp = swFeat.GetMaterialPropertyValues2(swInConfigurationOpts_e.swThisConfiguration, Empty)
    vProp(0) = 1 'Val("&H" + Mid(MyColor, 5, 2)) / 255  'red
    vProp(1) = 0 'Val("&H" + Mid(MyColor, 3, 2)) / 255  'green
    vProp(2) = 0 'Val("&H" + Mid(MyColor, 1, 2)) / 255  'blue
    vProp(3) = 1         'Ambient
    vProp(4) = 1         'Diffuse
    vProp(5) = 0.5       'Specularity
    vProp(6) = 0.3125    'Shininess
    vProp(7) = 0         'Transparency
    vProp(8) = 0         'Emission
    swFeat.SetMaterialPropertyValues2 vProp, swInConfigurationOpts_e.swAllConfiguration, Empty
End Sub

 

[roldy]

Wouldn't applying color to the Structural Member Feature color every body of that feature the same? I will be pulling color data from my Excel file that will eventually color every body differently.

Edit: Worst case scenario is that after creating all the bodies, within the For Each vBody loop I can look at the name of the body compare the nth name to the nth-1 name and see if the spileprofile(***) changes. If it does change I create a new folder and move the selected bodies to it. As for coloring, I suppose I might be able to create an array combining all the color values of each sheet and then as a I run through each body I can pull the correct color from the array. These would be a last resort because I believe there is a better way of doing this.

 

[fifiririloulou]

If you color every bodies differently, you should create a new feature for each. Then apply the color either to the feature or its body, before looping to the next line.

 

[roldy]

I think I would still have a problem because of vBodies = swModel.GetBodies2(). I renamed the CreateSketch subroutine to CreateSpiles and put the CreateWeldment and Apply Color subroutines inside the worksheet loop. Every worksheet loop needs to run those subroutines. The GetBodies2 still finds all the bodies it found before and thus the colors I had on them before won't stay. I need a way to only collect the bodies created on the current worksheet and put only those in a folder and only color those ones. I can't figure out a search routine for this.

Edit: I've re-uploaded the zip file with the changes I made. In the ApplyColor subroutine I was experimenting with a boolean trigger to create a folder only when a new weldment is created. Two folders are created because I only have two sheets thus far but the second folder is inside the first folder and all the bodies are in the second folder. Even though the bodies show all red, they eventually will be all different colors when I pull that information from the table.

https://files.engineering.com/getfi...-a974-413e-bc33-6a93b41f1e59&file=testing.zip

 

[fifiririloulou]

This will give each body a random color and put them in a folder

Option Explicit
Dim xlApp As Excel.Application
Sub main()
    Dim swApp As SldWorks.SldWorks
    Dim swModel As SldWorks.ModelDoc2
    Set swApp = Application.SldWorks
    Set swModel = swApp.ActiveDoc
    SetWeldmentParams swModel
    GetExcel Empty
    CreateSketch swModel
    swModel.ClearSelection2 True
End Sub

Sub CreateSketch(swModel As SldWorks.ModelDoc2)
    Dim xlWB As Excel.Workbook
    Dim xlSH As Excel.Worksheet
    Dim swSketchMgr As SldWorks.SketchManager
    Dim swSketch As SldWorks.Sketch
    Dim i As Integer
    Dim ws As Integer
    Dim x1, y1, z1, x2, y2, z2 As Double
    Dim deltaX As Double
    Dim deltaZ As Double
    Dim FeatName As String
    Dim ToRad As Double
    ToRad = 3.14159 / 180
    
    Set swSketchMgr = swModel.SketchManager
    Set xlWB = xlApp.Workbooks.Open("C:\testing\Spiles\CreateSpiles.xls")

    For ws = 1 To xlWB.Worksheets.Count

        Set xlSH = xlWB.Worksheets(ws)

        swSketchMgr.Insert3DSketch True
        Set swSketch = swSketchMgr.ActiveSketch
        
        For i = 2 To xlSH.Cells(xlSH.Rows.Count, 1).End(xlUp).Row - 1
            If i = 2 Then
                x1 = xlSH.Cells(i, 6).Value
                y1 = xlSH.Cells(i, 7).Value
                z1 = xlSH.Cells(i, 8).Value
            Else
                x1 = x2
                y1 = y2
                z1 = z2
            End If
            
            deltaX = xlSH.Cells(i + 1, 2).Value * Sin(xlSH.Cells(i + 1, 3).Value * ToRad)
            deltaZ = xlSH.Cells(i + 1, 2).Value * Cos(xlSH.Cells(i + 1, 3).Value * ToRad)
                
            x2 = x1 + deltaX
            y2 = y1
            z2 = z1 + deltaZ
        
            swModel.CreateLine2 x1, y1, z1, x2, y2, z2
        Next
        
        swSketchMgr.Insert3DSketch True
        swModel.BlankSketch

        FeatName = CreateWeldment(swModel, swSketch)
        ApplyColor swModel, FeatName, xlSH.Name

    Next ws
    
    xlApp.Visible = True
    xlWB.Close
    xlApp.Quit
    Set xlSH = Nothing
    Set xlWB = Nothing
    Set xlApp = Nothing

End Sub

Sub GetExcel(void)
On Error GoTo xls
    Set xlApp = GetObject(, "Excel.Application")
xls:
    If xlApp Is Nothing Then Set xlApp = New Excel.Application
    xlApp.Visible = False
End Sub

Function CreateWeldment(swModel As SldWorks.ModelDoc2, swSketch As SldWorks.Sketch) As String
    Dim swFeatMgr As SldWorks.FeatureManager
    Dim swStrucGroup As SldWorks.StructuralMemberGroup
    Dim vGroup(0) As Object
    Dim vSkSeg As Variant
    Dim vSkSegs As Variant
    Dim swSkSeg As SldWorks.SketchSegment
    Dim swFeat As SldWorks.Feature
    Dim ProfilePath As String
    
    Set swFeatMgr = swModel.FeatureManager
    Set swStrucGroup = swFeatMgr.CreateStructuralMemberGroup
    vSkSegs = swSketch.GetSketchSegments

    swStrucGroup.Segments = vSkSegs
    swStrucGroup.ApplyCornerTreatment = True
    swStrucGroup.CornerTreatmentType = 1
    swStrucGroup.Angle = 0
    Set vGroup(0) = swStrucGroup

    ProfilePath = "C:\testing\Spiles\spileprofile.SLDLFP"
    Set swFeat = swFeatMgr.InsertStructuralWeldment5(ProfilePath, swConnectedSegmentsOption_e.swConnectedSegments_SimpleCut, False, vGroup, Empty)
    CreateWeldment = swFeat.Name
End Function

Sub SetWeldmentParams(swModel As SldWorks.ModelDoc2)
    Dim swPart As SldWorks.PartDoc
    Dim swFeatMgr As SldWorks.FeatureManager
    Dim swFeat As SldWorks.Feature
    Dim swBodyFolder As SldWorks.BodyFolder
    
    Set swFeatMgr = swModel.FeatureManager
    Set swPart = swModel
    If swPart.IsWeldment = False Then swFeatMgr.InsertWeldmentFeature

    Set swFeat = swModel.FirstFeature
    While Not swFeat Is Nothing
        If swFeat.GetTypeName2 = "CutListFolder" Then
            Set swBodyFolder = swFeat.GetSpecificFeature2
            swBodyFolder.SetAutomaticCutList False
            swBodyFolder.SetAutomaticUpdate False
        End If
        If swFeat.GetTypeName2 = "SolidBodyFolder" Then
            Set swBodyFolder = swFeat.GetSpecificFeature2
            swBodyFolder.SetAutomaticCutList False
            swBodyFolder.SetAutomaticUpdate False
        End If
        Set swFeat = swFeat.GetNextFeature
    Wend
End Sub

Sub ApplyColor(swModel As SldWorks.ModelDoc2, FeatName As String, FolderName As String)
    Dim swBody As SldWorks.Body2
    Dim vBody As Variant
    Dim vBodies As Variant
    Dim vProp2(8) As Variant
    Dim vProp As Variant
    Dim swFeat As SldWorks.Feature

    vBodies = swModel.GetBodies2(swBodyType_e.swSolidBody, True)
    swModel.ClearSelection2 True
    
    For Each vBody In vBodies
        Set swBody = vBody
        If InStr(swBody.Name, FeatName) > 0 Then
            swBody.Select2 True, Nothing
                        
            swBody.MaterialPropertyValues2 = vProp2
            vProp = swBody.MaterialPropertyValues2
    
            Randomize
            vProp(0) = Rnd 'Val("&H" + Mid(MyColor, 5, 2)) / 255  'red
            Randomize
            vProp(1) = Rnd 'Val("&H" + Mid(MyColor, 3, 2)) / 255  'green
            Randomize
            vProp(2) = Rnd 'Val("&H" + Mid(MyColor, 1, 2)) / 255  'blue
            
            vProp(3) = 1         'Ambient
            vProp(4) = 1         'Diffuse
            vProp(5) = 0.5       'Specularity
            vProp(6) = 0.3125    'Shininess
            vProp(7) = 0         'Transparency
            vProp(8) = 0         'Emission
            swBody.MaterialPropertyValues2 = vProp
        End If
    Next

    Set swFeat = swModel.FeatureManager.InsertSubWeldFolder
    swFeat.Name = FolderName
End Sub

 

[roldy]

This is exactly what I needed. Thank you. I totally forgot that I can make a folder for a weldment and it would be in the cutlist. Last night I was coding an alternative by searching the faces of the weldment feature to get the bodies which then I could change the color and select and add them to a folder. Of course I would have to create a collection so that I could check if I already had found the same body.