Keep Part Body Color in Part 2 Product Macro

[jzecha]

I have a Part 2 Product macro and wanted to know if it is possible to modify the code to keep the part body color of the starting part when it creates a part out of it.
If it is possible, can somebody please provide me the code to add to my existing Part 2 Product macro?

 

[Little Cthulhu]

Care to post macro code?

 

[jzecha]

It is a work in progress, but works almost exactly how I want it too.
Just need to figure a way to keep the colors of the different bodies in the initial part.

'******************************************************************************

Sub CATMain()
CATIA.RefreshDisplay = False
Dim i As Integer
Dim n As Integer
Dim name As String
Dim prt As String
Dim BodyName() As String
Dim partDocument1 As PartDocument
On Error Resume Next
Set partDocument1 = CATIA.ActiveDocument
    If Err.Description = "Type mismatch" Then
        MsgBox "You must have a CATPart as active document"
        Exit Sub
    End If
name = partDocument1.FullName
Dim part1 As part
Set part1 = partDocument1.part
Dim bodies1 As Bodies
Set bodies1 = part1.Bodies
Dim body1 As Body
Dim sel As Selection
Set sel = partDocument1.Selection
Dim documents2 As Documents
Dim partDocument2 As PartDocument
Dim part2 As part
Dim specsAndGeomWindow1 As SpecsAndGeomWindow
n = bodies1.Count
If n = 1 Then
    MsgBox "There is only one body in:" & Chr(13) & name & Chr(13) & "Part MUST have at least 2 Body's" & Chr(13) & "Macro will end now!!!", vbExclamation, "Warning"
Exit Sub
End If
prt = Left(partDocument1.name, Len(partDocument1.name) - 8)
For i = 1 To n
    ReDim Preserve BodyName(i)
    'BodyName(i) = prt & "_" & bodies1.Item(i).name & "_" & i      'turn on if you want to number part bodies
    BodyName(i) = bodies1.Item(i).name & "_" & i      'turn on if you want to number part bodies but not include part name in new name
    'BodyName(i) = prt & "_" & bodies1.Item(i).name                 'turn on if you don't want to number part bodies
    'BodyName(i) = bodies1.Item(i).name                 'turn on if you don't want to number part bodies and not include part name in new name
    Set partDocument1 = CATIA.ActiveDocument
    sel.Clear
    sel.Add bodies1.Item(i)
    sel.Copy
    Set documents2 = CATIA.Documents
    Set partDocument2 = documents2.Add("Part")
    partDocument2.Product.PartNumber = BodyName(i)
    Set partDocument2 = CATIA.ActiveDocument
    Set specsAndGeomWindow1 = CATIA.ActiveWindow
    Set part2 = partDocument2.part
    sel.Add part2
    sel.PasteSpecial ("CATPrtResult")
    part2.Update
    Set partDocument2 = CATIA.ActiveDocument
    partDocument2.SaveAs Left(name, Len(name) - Len(partDocument1.name)) & BodyName(i) & ".CATPart"
    specsAndGeomWindow1.Close
    partDocument2.Close
Next

Dim documents1 As Documents
Set documents1 = CATIA.Documents
Dim productDocument1 As ProductDocument
Set productDocument1 = documents1.Add("Product")
productDocument1.Product.PartNumber = "Product_From_Part_" & Left(partDocument1.name, Len(partDocument1.name) - 8)
Dim product1 As Product
Set product1 = productDocument1.Product
Dim products1 As Products
Set products1 = product1.Products
Dim arrayOfVariantOfBSTR1(0)
Dim constraints1 As Constraints
Set constraints1 = product1.Connections("CATIAConstraints")
Dim reference1 As Reference
Dim constraint1 As Constraint
Dim ConString As String

For i = 1 To n
    ConString = ""
    ConString = "Product_From_Part_" & prt & "/" & BodyName(i) & ".1/!" & " " & prt & "/" & BodyName(i) & ".1/"
    arrayOfVariantOfBSTR1(0) = Left(name, Len(name) - Len(partDocument1.name)) & BodyName(i) & ".CATPart"
    Set products1Variant = products1
    StrConstrain = "Product_From_Part_" & Left(partDocument1.name, Len(partDocument1.name) - 8) & "/" & Left(partDocument1.name, Len(partDocument1.name) - 8) & "_PartBody.1/!" & "Product_From_Part_" & Left(partDocument1.name, Len(partDocument1.name) - 8) & "/" & Left(partDocument1.name, Len(partDocument1.name) - 8) & "_PartBody.1/"
    products1Variant.AddComponentsFromFiles arrayOfVariantOfBSTR1, "All"
    Set reference1 = product1.CreateReferenceFromName(ConString)
    Set constraint1 = constraints1.AddMonoEltCst(catCstTypeReference, reference1)
Next

CATIA.RefreshDisplay = True
End Sub

 

[itsmyjob]

I suggest you play with the following settings...

Eric N.
indocti discant et ament meminisse periti ​

 

[Little Cthulhu]

Got it, try this:

1. Add before sel.Copy:

Dim r, g, b
sel.Item(1).VisProperties.GetRealColor r, g, b

2. Add after sel.PasteSpecial

sel.Clear
sel.Add part2.Bodies.Item(2)
sel.Item(1).VisProperties.SetRealColor r, g, b, true

As always, typed this from my phone, so no testing done, sorry.

 

[jzecha]

@itsmyjob that works perfectly, except I would like to keep from forcing all the other users change their settings when using this macro.
@Little Cthulhu I will have to play with that in my code for future uses.

I believe I figured it out after searching long enough.
These two links helped me:

http://www.scripting4v5.com/how-to-pastespecial-with-a-catia-macro/

http://www.coe.org/p/fo/et/thread=16638

Here is my updated code:

Sub CATMain()
CATIA.RefreshDisplay = False
Dim i As Integer
Dim n As Integer
Dim name As String
Dim prt As String
Dim BodyName() As String
Dim partDocument1 As PartDocument
On Error Resume Next
Set partDocument1 = CATIA.ActiveDocument
    If Err.Description = "Type mismatch" Then
        MsgBox "You must have a CATPart as active document"
        Exit Sub
    End If
name = partDocument1.FullName
Dim part1 As part
Set part1 = partDocument1.part
Dim bodies1 As Bodies
Set bodies1 = part1.Bodies
Dim body1 As Body
Dim sel As Selection
Set sel = partDocument1.Selection
Dim documents2 As Documents
Dim partDocument2 As PartDocument
Dim part2 As part
Dim specsAndGeomWindow1 As SpecsAndGeomWindow
n = bodies1.Count
If n = 1 Then
    MsgBox "There is only one body in:" & Chr(13) & name & Chr(13) & "Part MUST have at least 2 Body's" & Chr(13) & "Macro will end now!!!", vbExclamation, "Warning"
Exit Sub
End If
prt = Left(partDocument1.name, Len(partDocument1.name) - 8)
For i = 1 To n
    ReDim Preserve BodyName(i)
    BodyName(i) = prt & "_" & bodies1.Item(i).name & "_" & i      'turn on if you want to number part bodies
    'BodyName(i) = bodies1.Item(i).name & "_" & i      'turn on if you want to number part bodies but not include part name in new name
    'BodyName(i) = prt & "_" & bodies1.Item(i).name                 'turn on if you don't want to number part bodies
    'BodyName(i) = bodies1.Item(i).name                 'turn on if you don't want to number part bodies and not include part name in new name
    Set partDocument1 = CATIA.ActiveDocument
    sel.Clear
    sel.Add bodies1.Item(i)
    sel.Copy
    Set documents2 = CATIA.Documents
    Set partDocument2 = documents2.Add("Part")
    partDocument2.Product.PartNumber = BodyName(i)
    Set partDocument2 = CATIA.ActiveDocument
    Set specsAndGeomWindow1 = CATIA.ActiveWindow
    Set part2 = partDocument2.part
    'sel.Add part2
    Dim sel2
    Set sel2 = partDocument2.Selection
    sel2.Clear
    sel2.Add part2
    sel2.Paste
    'sel.PasteSpecial "CATPrtResultWithOutLink"
    Set BodyToDelete = part2.Bodies.Item(1)
    part2.MainBody = part2.Bodies.Item(2)
    part2.Update
    sel.Clear
    sel.Add part2.Bodies.Item(1)
    Catia.ActiveDocument.Selection.Add BodyToDelete 
    Catia.ActiveDocument.Selection.Delete 
    part2.Update
    sel.Clear
    Set partDocument2 = CATIA.ActiveDocument
    partDocument2.SaveAs Left(name, Len(name) - Len(partDocument1.name)) & BodyName(i) & ".CATPart"
    specsAndGeomWindow1.Close
    partDocument2.Close
Next

Dim documents1 As Documents
Set documents1 = CATIA.Documents
Dim productDocument1 As ProductDocument
Set productDocument1 = documents1.Add("Product")
productDocument1.Product.PartNumber = "Product_From_Part_" & Left(partDocument1.name, Len(partDocument1.name) - 8)
Dim product1 As Product
Set product1 = productDocument1.Product
Dim products1 As Products
Set products1 = product1.Products
Dim arrayOfVariantOfBSTR1(0)
Dim constraints1 As Constraints
Set constraints1 = product1.Connections("CATIAConstraints")
Dim reference1 As Reference
Dim constraint1 As Constraint
Dim ConString As String

For i = 1 To n
    ConString = ""
    ConString = "Product_From_Part_" & prt & "/" & BodyName(i) & ".1/!" & " " & prt & "/" & BodyName(i) & ".1/"
    arrayOfVariantOfBSTR1(0) = Left(name, Len(name) - Len(partDocument1.name)) & BodyName(i) & ".CATPart"
    Set products1Variant = products1
    StrConstrain = "Product_From_Part_" & Left(partDocument1.name, Len(partDocument1.name) - 8) & "/" & Left(partDocument1.name, Len(partDocument1.name) - 8) & "_PartBody.1/!" & "Product_From_Part_" & Left(partDocument1.name, Len(partDocument1.name) - 8) & "/" & Left(partDocument1.name, Len(partDocument1.name) - 8) & "_PartBody.1/"
    products1Variant.AddComponentsFromFiles arrayOfVariantOfBSTR1, "All"
    Set reference1 = product1.CreateReferenceFromName(ConString)
    Set constraint1 = constraints1.AddMonoEltCst(catCstTypeReference, reference1)
Next

CATIA.RefreshDisplay = True
End Sub

 

[itsmyjob]

if you want to use the settings, have the macro read them when the it starts , then set them for the copy/paste, then put them back to before macro state...

Eric N.
indocti discant et ament meminisse periti ​

 

[jzecha]

That's a good idea, I had not thought about it.
My code works the way i needed it, just had to figure out how to select the part prior to pasting to keep the color the original body had.

I have another question if anyone can point me in the right direction.
I handle a bunch of parts I have to convert to products.
Most of the parts lately have the detail numbers on the bodies.
When I run my macro and there is multiple bodies named the same, the only way I have figured out how to prevent an error from duplicate names is to just number every body that is converted into a part.

Through my searching, everyone suggests writing the code in VBA to handle comparing the names and collectors.
What I would like to do is just rename the bodies before I run the Part 2 Product macro.
My parts starts with the following and I would like it changed to what is shown below:
Start
X
X
X
Y
Y
Z
Z
Renamed
X_1
X_2
X_3
Y_1
Y_2
Z_1
Z_2

I have tried to search for something like this and had zero luck.
Can someone please point me in the right direction to get started?

If this can be done in CATScript that would be even better, but I am not holding my breath on it.

 

[Little Cthulhu]

Do you really need this additional index to be sequential?
If no, simply use unique index each time, Timer() function should be enough in your case:

newProduct.PartNumber = originalPartNumber + "_" + CStr(Round(Timer() * 1000, 0))

If yes, you do want index to look nice (for whatever reason), then implementing it yourself is quite trivial with Scripting.Dictionary. Keys are partnumbers, values are indices:

Dim pnMap: set pnMap = CreateObject("Scripting.Dictionary")
...
if not pnMap.Exists(originalPartNumber) then
pnMap.Add originalPartNumber, 0
end if
pnMap(originalPartNumber) = pnMap(originalPartNumber) + 1
newProduct.PartNumber = originalPartNunber + "_" + CStr(pnMap(originalPartNumber))

Personally I'd pick first approach (unique indices) as sequentual indices are very rarely have any use. It's just more compkicated way of obscuring original name.

P.S. By the way both solutions are VBScript compliant.