Convert a CATpart bodies to CATProduct 1

[mnash60]

I'm new to catia vb hoping theirs someone that can help me. I found this script that works for me except for to things. One it errors out if there is a multiple bodies with the same name and i need the body color of the initial body copied. below is the code.


Dim KomponenteNeu As Products
Dim KoerperName
Dim OpenKoerperName
Dim hybridBodies As Document
Dim Koerper As Object
Dim QuellFenster As Window
Dim Letztekoerper
Dim UserSel As Selection


Sub CATMain()

Dim Activdocu As Document
Set Activdocu = CATIA.ActiveDocument

'---------------------------------------------------
' Neue Product
'---------------------------------------------------
Dim PosString As Long

partName = CATIA.ActiveDocument.name

Dim docu As Documents
Set docu = CATIA.Documents

Dim productDocu As Document
Set productDocu = docu.Add("Product")

Dim ProductNeu As Product
Set ProductNeu = productDocu.Product

PosString = InStr(1, partName, ".CATPart")
ProductNeu.PartNumber = Mid(partName, 1, PosString - 1)
'------------------------------------------------------

FensterNebeneinander

Set QuellFenster = CATIA.Windows.Item(1)
QuellFenster.Activate

Dim partBodies As Bodies
'Set Activdocu = CATIA.ActiveDocument
Set partBodies = Activdocu.Part.Bodies

Dim koerperAnzahl
koerperAnzahl = partBodies.Count

Dim UserSel As Object
For i = 1 To koerperAnzahl

Set Koerper = partBodies.Item(i)
KoerperName = Koerper.name

If Right(KoerperName, 1) = "\" Then
KoerperName = Left(KoerperName, Len(KoerperName) - 1)
End If

KoerperName = Replace(KoerperName, "\", "_")

'Koerper kopieren
Activdocu.Selection.Clear
Activdocu.Selection.Add Koerper
Activdocu.Selection.Copy
Activdocu.Selection.Clear

'if part already exist

'Part erzeugen und Koerper einfuegen
Dim PartNeu As Product
Set PartNeu = ProductNeu.Products.AddNewComponent("Part", CStr(KoerperName))

' Fenster mit neue Product activieren
ProductNeu.Parent.Activate

' Alle Parts suchen
PartSuchen ProductNeu.Parent, UserSel

'ProductNeu.parent.Selection.Clear
'ProductNeu.parent.Selection.Add UserSel.Item(UserSel.Count).Value
ProductNeu.Parent.Selection.Clear
ProductNeu.Parent.Selection.Add ProductNeu.Products.Item(PartNeu).ReferenceProduct.Parent.Part
ProductNeu.Parent.Selection.PasteSpecial "CATPrtResult"
ProductNeu.Parent.Selection.Clear

Next

Dim hybridBodies As hybridBodies
'Set Activdocu = CATIA.ActiveDocument
Set hybridBodies = Activdocu.Part.hybridBodies

koerperAnzahl = hybridBodies.Count

For i = 1 To koerperAnzahl

Set Koerper = hybridBodies.Item(i)
KoerperName = Koerper.name

If Right(KoerperName, 1) = "\" Then
KoerperName = Left(KoerperName, Len(KoerperName) - 1)
End If

KoerperName = Replace(KoerperName, "\", "_")

'Koerper kopieren
Activdocu.Selection.Clear
Activdocu.Selection.Add Koerper
Activdocu.Selection.Copy
Activdocu.Selection.Clear

'Part erzeugen und Koerper einfuegen
Set PartNeu = ProductNeu.Products.AddNewComponent("Part", CStr(KoerperName))

' Fenster mit neue Product activieren
ProductNeu.Parent.Activate

' Alle Parts suchen
PartSuchen ProductNeu.Parent, UserSel

'ProductNeu.parent.Selection.Clear
'ProductNeu.parent.Selection.Add UserSel.Item(UserSel.Count).Value
ProductNeu.Parent.Selection.Clear
ProductNeu.Parent.Selection.Add ProductNeu.Products.Item(PartNeu).ReferenceProduct.Parent.Part
ProductNeu.Parent.Selection.Paste
ProductNeu.Parent.Selection.Clear

Next

' Product actualisieren
ProductNeu.ApplyWorkMode DESIGN_MODE
On Error Resume Next
ProductNeu.Update
If Err <> 0 Then
MsgBox "Problem with update!" & vbLf & vbLf & "Please update manual!", vbCritical + vbOKOnly, "Update-Error"
End If
On Error GoTo 0

End Sub


Sub PartSuchen(oPartDoc1, UserSel)

Dim E As Object 'CATBSTR
Dim Was(0)
Was(0) = "Part"

'Dim UserSel As Object
Set UserSel = oPartDoc1.Selection
UserSel.Clear

'Let us first fill the CSO with all the objects of the model
UserSel.Search ("CATPrtSearch.PartFeature,all")

'E = UserSel.SelectElement2(Was, "Alle CATPart wählen", True)
'Letztekoerper = UserSel.Count

End Sub


Sub FensterNebeneinander()

Dim windows1 As Windows
Set windows1 = CATIA.Windows

windows1.Arrange catArrangeTiledVertical

End Sub



Can someone please help me out?

 

[jzecha]

Here is a more advanced version of that Macro that I have tweaked over the last few years.

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
On Error Goto 0
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)

	'///////////////		start v1.03		////////////////
	'Dim intCount
	intCount = 0
	For k = 1 to i
		If bodies1.Item(i).Name = bodies1.Item(k).Name then
			intCount = intCount + 1
		End If
	Next
	BodyName(i) = prt & "_" & bodies1.Item(i).name & "_" & intCount
	'///////////////		end v1.03		////////////////

    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
    Set BodyToDelete = part2.Bodies.Item(1)
    Dim sel2
    Set sel2 = partDocument2.Selection
    sel2.Clear
    sel2.Add part2
	sel2.Paste
	
	
	On Error Resume Next
	If Err.Description = "The Method Paste Failed" Then
        sel2.PasteSpecial
        Exit Sub
    End If
	On Error Goto 0
	
	
    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

Dim ProductDoc1_As_Document
Set ProductDoc1 = Catia.ActiveDocument

Dim Selection1_As_Selection
Set Selection1 = ProductDoc1.Selection

selection1.Search "CATPrtSearch.Plane,all"
Set visPropertySet1 = Selection1.visProperties
VisPropertySet1.SetShow 1
Selection1.Clear

selection1.Search "CATAsmSearch.MfConstraint,all"
Set visPropertySet1 = Selection1.visProperties
VisPropertySet1.SetShow 1
Selection1.Clear

MsgBox "All Done!"
End Sub

 

[mnash60]

This script seems to work on my simple bodies. but what if I have part body like this

I want to remove everything from the first backslash and then remove all the slashes so i can save it to a directory. right now I get this error.

Thanks for the help. I really appreciate it.

 

[jzecha]

I believe you need to remove all the illegal symbols and shorten the names of every part because the part numbers are too long.

I use this code to assist in that:
Once you run the script and finish removing everything, you will need to save the part before you run the Part2Product Macro.

Sub CATMain()

Dim myPart As Part
Set myPart = CATIA.ActiveDocument.Part

Dim myBody As Body

Dim newName As String
Dim newCharacter As String
newCharacter = " "


input=InputBox ("Enter Character or Strings to Remve from Part Bodies"& vbNewLine & "TEXT IS CASE SENSITIVE" , "Custom String Removal")
Dim Input As String

For Each myBody In myPart.Bodies 'loop through all the bodies in the part

    newName = myBody.Name 'get the current body's name

	newName = Replace(newName,input,"")

myBody.Name = newName 'rename the current body with the revised name

Next

MsgBox "All Done!"
End Sub

 

[LINGSHUYING]

Hello all,
Here is a more clearly and concisely version of VBA Macro programming I wrote recently,
it can convert all the CATPart's Bodies or custom select Bodies to CATProduct .
Of course,it can rename the Body's name if it's duplicate.
1 wish I could help you.

[COLOR=#5C3566]'The first Code is to convert all the CATPart's Bodies to CATProduct:[/color]
 Sub GreateProductsFromBodies_SelectAllBodies()
    [COLOR=#4E9A06]'Purpose : Create  Product's  from Part's Bodies[/color]
    [COLOR=#4E9A06]'add Error control and connect to CATIA application
[/color]    On Error Resume Next
    Set CATIA = GetObject(, "CATIA.Application")
    
    [COLOR=#4E9A06]'Declare variables
[/color]    Dim oPartDoc As PartDocument
    Dim oPart As Part
    Dim oProductDoc As ProductDocument
    Dim oProduct As Product
    
    [COLOR=#4E9A06]'Create a new ProductDoc and rename it's PartNumber equals to Partdoc's PartNumber[/color]
    Set oPartDoc = CATIA.ActiveDocument
    Set oProductDoc = CATIA.Documents.Add("Product")
    oProductDoc.Product.PartNumber = oPartDoc.Product.PartNumber
    
    [COLOR=#4E9A06]'Arrange windows use "Title Vertically" ,then active window contain Partdoc
[/color]    CATIA.Windows.Arrange catArrangeTiledVertical
    CATIA.Windows.Item(1).Activate
    
    [COLOR=#4E9A06]'Check the Body's name use "For ... Next"loop . If Body's name duplicate,then rename.
[/color]    Dim j As Integer, k As Integer
    For j = 1 To oPartDoc.Part.Bodies.Count
        For k = 1 To oPartDoc.Part.Bodies.Count
            If oPartDoc.Part.Bodies.Item(j).Name = oPartDoc.Part.Bodies.Item(k).Name And j <> k Then
                oPartDoc.Part.Bodies.Item(j).Name = oPartDoc.Part.Bodies.Item(k).Name & "_Rename_" & j
            End If
        Next
    Next
    
    [COLOR=#4E9A06]'Copy Bodies from PartDocument
[/color]    Dim i As Integer, ProductPN As String, FinalProductPN As String
    For i = 1 To oPartDoc.Part.Bodies.Count
        With oPartDoc.Selection
            .Clear
            .Add oPartDoc.Part.Bodies.Item(i)
            .Copy
            .Clear
        End With
        
         [COLOR=#4E9A06]'Modify the Product's PartNumber,replace "\" and "."to "_" ,then delete Space
[/color]        ProductPN = oPartDoc.Part.Bodies.Item(i).Name
        If Right(ProductPN, 1) = "\" Then
            ProductPN = Left(ProductPN, Len(ProductPN) - 1)
        End If
        FinalProductPN = Replace(Replace(Replace(ProductPN, "\", "_"), ".", "_"), " ", "") 'Replace "\" and "."to "_",Delete Space
        
        [COLOR=#4E9A06]  'Paste Body in Product's Part as Result
[/color]        Set oProduct = oProductDoc.Product.Products.AddNewComponent("Part", FinalProductPN) 'Add Part
        With oProductDoc.Selection
            .Clear
            .Add oProductDoc.Product.Products.Item(i).ReferenceProduct.Parent.Part
            .PasteSpecial "CATPrtResultWithOutLink"
            .Clear
        End With
        oProductDoc.Product.Products.Item(i).ReferenceProduct.Parent.Part.Update
    Next
    
   [COLOR=#4E9A06] 'Use Msgbox to echo the complete flag
[/color]    MsgBox "All the select Bodies had been created as a PartDocument successfully !" & Chr(13) & _
    ">>> The Partdocument's Bodies's count : " & oPartDoc.Part.Bodies.Count & Chr(13) & _
    ">>> The ProductDocument's PartDocument's count : " & oProductDoc.Product.Products.Count, _
    vbOKOnly + vbInformation, "@LSY >>> CATIAVBAMacro of Part to Product >>> Run Result"
      
End Sub

[COLOR=#5C3566]'The second Code is to convert custom select CATPart's Bodies to CATProduct:[/color]
Sub GreateProductsFromBodies_CustomToSelectBodies()
    [COLOR=#4E9A06]'Purpose : Create  Product's  from Part's Bodies
[/color]    
    [COLOR=#4E9A06]'add Error control and connect to CATIA application
[/color]    On Error Resume Next
    Set CATIA = GetObject(, "CATIA.Application")
    
  [COLOR=#4E9A06]  'Declare variables
[/color]    Dim oPartDoc As PartDocument
    Dim oPart As Part
    Dim oProductDoc As ProductDocument
    Dim oProduct As Product
    
    [COLOR=#4E9A06]'Create a new ProductDoc and rename it's PartNumber equals to Partdoc's PartNumber
[/color]    Set oPartDoc = CATIA.ActiveDocument
    Set oProductDoc = CATIA.Documents.Add("Product")
    oProductDoc.Product.PartNumber = oPartDoc.Product.PartNumber
    
    [COLOR=#4E9A06]'Arrange windows use "Title Vertically" ,then active window contain Partdoc
[/color]    CATIA.Windows.Arrange catArrangeTiledVertical
    CATIA.Windows.Item(1).Activate
    [COLOR=#4E9A06]
    'Check the Body's name use "For ... Next"loop . If Body's name duplicate,then rename.
[/color]    Dim j As Integer, k As Integer
    For j = 1 To oPartDoc.Part.Bodies.Count
        For k = 1 To oPartDoc.Part.Bodies.Count
            If oPartDoc.Part.Bodies.Item(j).Name = oPartDoc.Part.Bodies.Item(k).Name And j <> k Then
                oPartDoc.Part.Bodies.Item(j).Name = oPartDoc.Part.Bodies.Item(k).Name & "_Rename_" & j
            End If
        Next
    Next
    
  [COLOR=#4E9A06]  'Use Selection3 to relize comstom to select Bodies in the Partdocument.
[/color]    Dim ElementsArray(0), Status
    Set oSelection = CATIA.ActiveDocument.Selection
    oSelection.Clear
    ElementsArray(0) = "Body" '"AnyObject"
    Status = oSelection.SelectElement3(ElementsArray, "Select Bodies to create PartDocument !", _
                 True, CATMultiSelectionMode.CATMultiSelTriggWhenUserValidatesSelection, False)
               
[COLOR=#4E9A06]     'Copy Bodies from PartDocument[/color]
    Dim i As Integer, ProductPN As String, FinalProductPN As String
    For i = 1 To oSelection.Count
        With oSelection
            .Add oSelection.Item(i).Value
            .Copy
            .Clear
        End With
        
       [COLOR=#4E9A06] 'Modify the Product's PartNumber,replace "\" and "."to "_" ,then delete Space
[/color]        ProductPN = oPartDoc.Part.Bodies.Item(i).Name
        If Right(ProductPN, 1) = "\" Then
            ProductPN = Left(ProductPN, Len(ProductPN) - 1)
        End If
        FinalProductPN = Replace(Replace(Replace(ProductPN, "\", "_"), ".", "_"), " ", "")
        
       [COLOR=#4E9A06] 'Paste Body in Product's Part as Result
[/color]        Set oProduct = oProductDoc.Product.Products.AddNewComponent("Part", FinalProductPN) 'Add Part
        With oProductDoc.Selection
            .Clear
            .Add oProductDoc.Product.Products.Item(i).ReferenceProduct.Parent.Part
            .PasteSpecial "CATPrtResultWithOutLink"
            .Clear
        End With
        oProductDoc.Product.Products.Item(i).ReferenceProduct.Parent.Part.Update
    Next
    
   [COLOR=#4E9A06] 'Use Msgbox to echo the complete flag
[/color]    MsgBox "All the select Bodies had been created as a PartDocument successfully !" & Chr(13) & _
    ">>> The Partdocument's Bodies's count : " & oPartDoc.Part.Bodies.Count & Chr(13) & _
    ">>> The ProductDocument's PartDocument's count : " & oProductDoc.Product.Products.Count, _
    vbOKOnly + vbInformation, "@LSY >>> CATIAVBAMacro of Part to Product >>> Run Result"
End Sub

 

[Yulin]

How about do it by CATScript
Below is code

Sub catmain()
Set prtdoc = CATIA.ActiveDocument
Set prodoc = CATIA.Documents.Add("Product")
prodoc.product.partnumber = prtdoc.product.partnumber
For Each B In prtdoc.Part.Bodies
prtdoc.Selection.Add B
prtdoc.Selection.Copy
prtdoc.selection.Clear
Set Prd = prodoc.product.products.addnewcomponent("Part", "")
Prd.partnumber = B.name
prodoc.Selection.Add Prd.referenceproduct.Parent.Part
prodoc.Selection.PasteSpecial "CATPrtResultWithOutLink"
Prd.referenceproduct.Parent.Part.Update
Next
End Sub