Sub CATMain()
'Check to make sure the user is on the assembly workbench
If CATIA.GetWorkbenchId <> "Assembly" Then
MsgBox "Only works on the Assembly Design workbench", , "Workbench Error"
Exit Sub
End If
'Clear the undo stack in CATIA so that deleted files still in memory do not cause an error. Mainly caused during testing
CATIA.StartCommand ("Clear History")
Dim uSel As Selection
Set uSel = CATIA.ActiveDocument.Selection
'Check to make sure at least 2 items were selected
If uSel.Count < 2 Then
MsgBox "You must select two products before running this macro.", , "Selection Qty Error"
Exit Sub
End If
'Check to make sure the selected items are products
If TypeName(uSel.Item(1).Value) <> "Product" Or TypeName(uSel.Item(2).Value) <> "Product" Then
MsgBox "Both selected items must be products", , "Selection Type Error"
Exit Sub
End If
'Get the first selected product, this is the one with the master part files
Dim masterProd0010 As Product
Set masterProd0010 = uSel.Item(1).Value
'Get the second selected product, this will be where new parts are going to be made
Dim newProd0110 As Product
Set newProd0110 = uSel.Item(2).Value
'Check to make sure the newProd is actually a product node not a part
If TypeName(newProd0110.ReferenceProduct.Parent) <> "ProductDocument" Then
MsgBox "Both selected items must be products", , "Selection Type Error"
Exit Sub
End If
'Loop through all of the products in the master product
For i = 1 To masterProd0010.Products.Count
Dim loopProd As Product
Set loopProd = masterProd0010.Products.Item(i)
'If the looped product is a part node then execute the copy code
If TypeName(loopProd.ReferenceProduct.Parent) = "PartDocument" Then
'Get the part number of the master part that is being copied
Dim startPartNum As String
startPartNum = loopProd.PartNumber
'Get the instance name of the master part that is being copied
Dim startPartName As String
startPartName = loopProd.Name
'Create the part number for the new file that is going to be made. If there is a dash in the master part file change the extension to -0110 else addend -0110 to the whole part number
Dim newPartName As String
'Get the position of the '-' in the part number
Dim dashPos As Integer
dashPos = InStr(1, startPartNum, "-", vbTextCompare)
If dashPos = 0 Then
'If there isn't a dash then just addend -0110 onto the master part number
newPartName = startPartNum & "-0110"
Else
'Get the extension number after the dash
Dim extNum As String
extNum = Right(startPartNum, Len(startPartNum) - dashPos)
'If the extension is numeric then increment
If IsNumeric(extNum) Then
'Convert the old number to an integer
Dim oldNum As Integer
oldNum = CInt(extNum)
'Get the instance number
Dim instNum As Integer
instNum = 0
'Get the position of the '.' in the instance name
Dim decPos As Integer
decPos = InStr(1, startPartName, ".", vbTextCompare)
'If there is a decimal in the instance name then get the number else number is 0
If decPos = 0 Then
instNum = 0
Else
'Get the number string from the name
Dim instNumStr As String
instNumStr = Right(startPartName, Len(startPartName) - decPos)
'If it is numeric then set the instance number to the retrieved string, decremented by 1
If IsNumeric(instNumStr) Then
instNum = CInt(instNumStr) - 1
Else
instNum = 0
End If
End If
'Increment the old number by 100 to get the new number, also add the instance number
Dim newNum As Integer
newNum = oldNum + 100 + instNum
'Concatenate the new number onto the original base number
newPartName = Left(startPartNum, dashPos) & Format(newNum, "0000")
Else
'If the extension isn't numeric then just addend -0110 onto the master part number
newPartName = startPartNum & "-0110"
End If
End If
'Create the new part and get the object
Dim newPartProd As Product
Set newPartProd = newProd0110.Products.AddNewComponent("Part", newPartName)
Dim newPart As Part
Set newPart = newPartProd.ReferenceProduct.Parent.Part
'Move the new part to the same position as the original one
Dim oAxisComponentsArray(11)
Dim loopProdUnBnd
Set loopProdUnBnd = loopProd
loopProdUnBnd.position.GetComponents oAxisComponentsArray
Dim newPartProdUnBnd
Set newPartProdUnBnd = newPartProd
newPartProdUnBnd.position.SetComponents oAxisComponentsArray
'Select and copy all the bodies from the original part
uSel.Clear
uSel.Add loopProd
uSel.Search ("CATPrtSearch.BodyFeature,sel")
uSel.Copy
'Paste the body/bodies into the newly created part
uSel.Clear
uSel.Add newPart
uSel.PasteSpecial ("CATPrtResult")
'If a body was added to the new part then handle the new part update
If newPart.Bodies.Count > 1 Then
'Change the main body in the new part to the new body
newPart.MainBody = uSel.Item(1).Value
newPart.MainBody.Name = "PartBody"
'Delete the empty body that remains in the new part
uSel.Clear
uSel.Add newPart.Bodies.Item(1)
uSel.Delete
'Update the new part so the the body is up to date
newPart.Update
End If
End If
Next
End Sub
