Public Sub Option4()
Dim pctDone As Double
Dim iLabelWidth As Integer
iLabelWidth = 366
CATIA.RefreshDisplay = False
CATIA.DisplayFileAlerts = True
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
Start_Menu.lblStatus2.Caption = ("Part Body " & i & " of " & n)
Start_Menu.lblStatus1.Caption = ("Creating Parts")
pctDone = i / n
'MsgBox pctDone
Start_Menu.lblProgress.Width = iLabelWidth * pctDone
DoEvents
Start_Menu.FrameProgress.Caption = Format(pctDone, "0%")
DoEvents
ReDim Preserve BodyName(i)
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
Set BodyToDelete = part2.Bodies.Item(1)
Dim sel2
Set sel2 = partDocument2.Selection
sel2.Clear
sel2.Add part2
sel2.Paste
'sel2.PasteSpecial "CATPrtResultWithOutLink" 'Removes Colors
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
Start_Menu.lblStatus1.Caption = ("Creating Fix Constraints")
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
'MsgBox "All Done!"
Call HidePlanes
CATIA.DisplayFileAlerts = True
Start_Menu.Hide
' Start_Menu.OkCancel_Buttons.Visible = False
' Start_Menu.Partt2ProductRunning.Visible = False
' Start_Menu.OkCancel_Buttons2.Visible = True
' 'Start_Menu.Height = 330
CATIA.StatusBar = "Macro Finished"
MsgBox "All Done"
End Sub