Sub CATMain()
Dim SelCheck As Integer
SelCheck = CATIA.ActiveDocument.Selection.Count2
Dim HCheck As String
If SelCheck = 0 Then
MsgBox ("Items to be copied must be highlighted first")
Exit Sub
End If
If SelCheck <= 1 Then
HCheck = MsgBox("Are child components highlighted?", vbYesNo)
If HCheck = vbNo Then
MsgBox ("Hightlight items to be moved and try again")
Exit Sub
End If
End If
Dim NewCompName As String
NewCompName = InputBox("New Component Name", "Enter the name for the new component", "New Component")
Dim productDocument1 As ProductDocument
Set productDocument1 = CATIA.ActiveDocument
Dim product1 As Product
Set product1 = productDocument1.Product
Dim products1 As Products
Set products1 = product1.Products
Dim iProduct As Product
Dim pProduct As Product
Dim nProduct As Product
Set oSel = CATIA.ActiveDocument.Selection
Dim i As Integer
Dim FName As String
i = CATIA.ActiveDocument.Selection.Count2
Dim Sel As Selection
Set Sel = productDocument1.Selection
Dim PNumber As String
Dim IName As String
Dim n As Integer
Dim CutStart As Integer
NameCheck:
CutStart = 0
n = 0
For Each product1 In CATIA.ActiveDocument.Product.Products
n = n + 1
product1.ApplyWorkMode DESIGN_MODE
If product1.PartNumber = NewCompName Then
NewCompName = InputBox("New component name already used. Choose a different Name", "New Component")
GoTo NameCheck
End If
If product1.Name = oSel.Item(i).Value.Name Then
CutStart = n + 1 - i
End If
Next
Dim product2 As Product
Set product2 = products1.AddNewProduct("")
product2.Name = NewCompName & ".1"
product2.PartNumber = NewCompName
Set pProduct = products1.Item(NewCompName & ".1")
For i = 1 To CATIA.ActiveDocument.Selection.Count2
FName = oSel.Item(i).Value.Name
PNumber = oSel.Item(i).Value.PartNumber
Set iProduct = products1.Item(FName)
Sel.Add iProduct
Next
Sel.Cut
Dim Sel2 As Selection
Set Sel2 = CATIA.ActiveDocument.Selection
Sel2.Clear
Sel2.Add pProduct
AppActivate ("CATIA V5")
CATIA.StartCommand "FrmActivate"
Sel2.Paste
Sel2.Clear
Sel.Clear
n = n - i + 1
For i = CutStart To n
FName = products1.Item(i).Name
Set iProduct = products1.Item(FName)
Sel.Add iProduct
Next
Set iProduct = productDocument1.Product
Sel.Cut
Sel2.Add iProduct
Sel2.Paste
Sel2.Clear
End Sub