Script copy/paste Part bodys with position

[Iqtar]

Hello
the scripts below works fine in the case 2 only and I don’t see why doesn't work in the case 1
-Case 1 : when selected object = part > any bodies copied in the new part !
-Case 2: when selected object = sub Product > the script copies and Pasts the Part bodies in a new part with the position

can somebody help?

Script
----------------------------------------------------------------------

Option Explicit
Const strVersion As String = "V1.0"
Const strMacroName As String = "Poor Man's ProductToPart"
Public iBodyCount As Integer 'counter for stats
Public oRefAx As AxisSystem 'Part Ref axis system,1/1/1;0/0/0
Public oDestDoc As PartDocument 'destinaton for allcatpart

Sub CatMain()
Dim oRootProd As Product
Dim oSourceWindow As Window
Dim arrRootPos(11)
Dim tmStart As Date
Dim tmEnd As Date

tmStart = Time$
iBodyCount = 0

Set oSourceWindow = CATIA.ActiveWindow
Set oRootProd = GetRootProd
If oRootProd Is Nothing Then End
Set oDestDoc = CreateNewPart(oRootProd.Name & "_AllCatPart", "AllCatPart aus " & oRootProd.Name) 'create destination part
Set oRefAx = CreateNewAxisSp(oDestDoc.Part, "RefAxis")
oSourceWindow.Activate

arrRootPos(0) = 1 'reset axis cooords to
arrRootPos(1) = 0 'standard r/h system
arrRootPos(2) = 0
arrRootPos(3) = 0
arrRootPos(4) = 1
arrRootPos(5) = 0
arrRootPos(6) = 0
arrRootPos(7) = 0
arrRootPos(8) = 1
arrRootPos(9) = 0
arrRootPos(10) = 0
arrRootPos(11) = 0

CATIA.RefreshDisplay = False
CATIA.DisplayFileAlerts = False
CATIA.HSOSynchronized = False

RunTree oRootProd, arrRootPos()

oDestDoc.Part.Update

CATIA.HSOSynchronized = True
CATIA.DisplayFileAlerts = True
CATIA.RefreshDisplay = True
CATIA.StatusBar = "Macro finished. "

tmEnd = Time$
MsgBox "Start: " & tmStart & vbCrLf _
& "Ende: " & tmEnd & vbCrLf _
& iBodyCount & " Bodies copied.", _
vbOKOnly Or vbInformation, strMacroName & "/" & strVersion
End Sub

Function GetRootProd() As Product
Dim oSel As Selection

Set oSel = CATIA.ActiveDocument.Selection
If oSel.Count2 = 1 Then
If oSel.Item(1).Type = "Product" Then
Set GetRootProd = oSel.Item2(1).Value
Else
MsgBox "This macro needs a product to work!" & vbCr & "Exiting macro ...", vbOKOnly Or vbCritical, "GetRootProd - " & strMacroName & "/" & strVersion
End If
Else
MsgBox "Select a product first!" & vbCr & "Exiting macro ...", vbOKOnly Or vbCritical, "GetRootProd - " & strMacroName & "/" & strVersion
End
End If

End Function

Sub RunTree(oRoot As Product, arrRootProd())
Dim i As Integer
Dim n As Integer
Dim arrInv(11) 'inverse pos
Dim arrPos(11) 'part pos
Dim arrProdPos(11) 'prod pos
Dim arrResPos(11) 'result from part matrix multiply
Dim arrResProdPos(11) 'result from product matrix multiply
Dim oProdItem As Object 'Product
Dim strCoord As String
Dim oP As Part
Dim oSel As Selection 'source selection
Dim oDestSel As Selection 'destination selection
Dim showstate As CatVisPropertyShow
Dim strNewBody As String 'name of created body
Dim oTransAx As Object 'AxisSystem 'Dest Ax Sys for catpart Ax2Ax translation
Dim arrOrg(2) 'PutOrigin - array
Dim arrVX(2) 'PutXAxis - array
Dim arrVY(2) 'PutYAxis - array
Dim arrVZ(2) 'PutZAxis - array
Dim oRefRefAx As Reference 'Ref element source
Dim oRefTransAx As Reference 'Ref element dest
Dim oAxisToAxis As ShapeFactory 'translate op

'---------------------------------------------------------------------------------------------------

'---------------------------------------------------------------------------------------------------

Set oSel = CATIA.ActiveDocument.Selection

'HBA For i = 1 To oRoot.Products.Count
'MsgBox oRoot.Products.Item(i).Name
' Set oProdItem = oRoot.Products.Item(i)
Set oProdItem = oRoot.Products.Part

oSel.Clear
oSel.Add oProdItem 'check if noshow
oSel.VisProperties.GetShow showstate 'is the part visible, go on
oSel.Clear

If showstate = catVisPropertyShowAttr Then 'if noshow, skip
oProdItem.ApplyWorkMode (DEFAULT_MODE) 'set work mode to default

If TypeName(oProdItem.ReferenceProduct.Parent) = "ProductDocument" Then
oProdItem.Position.GetComponents arrProdPos 'get zb axis coords if in zb
'multiply new array with old array; FIRST arg must be NEW array!
MatrixProduct arrProdPos, arrRootProd, arrResProdPos 'build array product
RunTree oProdItem, arrResProdPos 'reenter one level down
ElseIf TypeName(oProdItem.ReferenceProduct.Parent) = "PartDocument" Then

oProdItem.Position.GetComponents arrPos

'combine axis position arrays
MatrixProduct arrPos, arrRootProd, arrResPos 'build resulting array (NEW,OLD,RESULT)!

Set oTransAx = CreateNewAxisSp(oDestDoc.Part, "TransAxis" & oRoot.Products.Item(i).Name, False)
oSel.Add oTransAx
oSel.VisProperties.SetShow catVisPropertyNoShowAttr 'set noshow
oSel.Clear

arrOrg(0) = arrResPos(9)
arrOrg(1) = arrResPos(10)
arrOrg(2) = arrResPos(11)
oTransAx.PutOrigin arrOrg

arrVX(0) = arrResPos(0)
arrVX(1) = arrResPos(1)
arrVX(2) = arrResPos(2)
oTransAx.PutXAxis arrVX

arrVY(0) = arrResPos(3)
arrVY(1) = arrResPos(4)
arrVY(2) = arrResPos(5)
oTransAx.PutYAxis arrVY

arrVZ(0) = arrResPos(6)
arrVZ(1) = arrResPos(7)
arrVZ(2) = arrResPos(8)
oTransAx.PutZAxis arrVZ

Set oRefRefAx = oDestDoc.Part.CreateReferenceFromObject(oRefAx)
Set oRefTransAx = oDestDoc.Part.CreateReferenceFromObject(oTransAx)

Set oP = oProdItem.ReferenceProduct.Parent.Part

For n = 1 To oP.Bodies.Count
If oP.Bodies.Item.InBooleanOperation = False Then 'if not root body, skip
If oP.Bodies.Item.Shapes.Count <> 0 Then 'if bodies are empty, skip
If oP.IsUpToDate(oP.Bodies.Item) = False Then 'if not up-to-date
oP.UpdateObject oP.Bodies.Item 'update the body
DoEvents 'just in case
End If

oSel.Add oP.Bodies.Item
oSel.Copy
oSel.Clear

Set oDestSel = oDestDoc.Selection
oDestSel.Clear
oDestSel.Add oDestDoc.Part
oDestSel.PasteSpecial "CATPrtResultWithOutLink"
DoEvents
oDestSel.Clear
strNewBody = oRoot.Products.Item(i).Name & "/" & oP.Bodies.Item.Name ' & "//" & strCoord
oDestDoc.Part.Bodies.Item(oDestDoc.Part.Bodies.Count).Name = strNewBody
' Debug.Print oProdItem.Name, oP.Bodies.Item.Name, oP.IsUpToDate(oP.Bodies.Item), showstate
Set oAxisToAxis = oDestDoc.Part.ShapeFactory.AddNewAxisToAxis2(oRefRefAx, oRefTransAx)
iBodyCount = iBodyCount + 1
End If
End If
Next
'---------------------------------------------------------------------------------------------------
Else
'other
End If
End If
'HBA Next
End Sub

Function CreateNewPart(strPNumber As String, strDescriptor As String) As PartDocument
Dim oADPDoc As PartDocument
Dim oADProd As Product

Set oADPDoc = CATIA.Documents.Add("Part") 'create new part
Set oADProd = CATIA.ActiveDocument.Product
oADProd.PartNumber = strPNumber 'change partnumber
oADProd.DescriptionRef = strDescriptor 'add descriptor
CATIA.ActiveDocument.Part.Update 'update
CATIA.StatusBar = "Creating New Part!"
Set CreateNewPart = oADPDoc
End Function

Function CreateNewAxisSp(oParent As Part, strAxisName As String, Optional iCurr As Boolean = True, Optional iAxType As CATAxisSystemMainType = catAxisSystemStandard) As AxisSystem
'ToDo
'Fehler abfangen: bei bereits vorhandenem Part gleichen namens in der session

Dim oAxSyst As AxisSystem

Set oAxSyst = oParent.AxisSystems.Add()
oParent.UpdateObject oAxSyst
oAxSyst.Type = iAxType
oAxSyst.IsCurrent = iCurr
oAxSyst.Name = strAxisName
oParent.Update
Set CreateNewAxisSp = oAxSyst
End Function

' ***********************************************************************
'
' Purpose: Define the product of two matrix.
'
' Inputs : matrix1 Array array corresponding to the first matrix
' matrix2 Array array corresponding to the second matrix
'
' Outputs: res Array array corresponding to the product
'
' ***********************************************************************
' Borrowed from Dassault macro
Public Sub MatrixProduct(ByVal matrix1, ByVal matrix2, ByRef res)

Dim a(11)
Dim b(11)
Dim i As Integer
For i = 0 To 11
a(i) = matrix1(i)
b(i) = matrix2(i)
Next

res(0) = a(0) * b(0) + a(1) * b(3) + a(2) * b(6)
res(3) = a(3) * b(0) + a(4) * b(3) + a(5) * b(6)
res(6) = a(6) * b(0) + a(7) * b(3) + a(8) * b(6)
res(1) = a(0) * b(1) + a(1) * b(4) + a(2) * b(7)
res(4) = a(3) * b(1) + a(4) * b(4) + a(5) * b(7)
res(7) = a(6) * b(1) + a(7) * b(4) + a(8) * b(7)
res(2) = a(0) * b(2) + a(1) * b(5) + a(2) * b(8)
res(5) = a(3) * b(2) + a(4) * b(5) + a(5) * b(8)
res(8) = a(6) * b(2) + a(7) * b(5) + a(8) * b(8)
res(9) = a(9) * b(0) + a(10) * b(3) + a(11) * b(6) + b(9)
res(10) = a(9) * b(1) + a(10) * b(4) + a(11) * b(7) + b(10)
res(11) = a(9) * b(2) + a(10) * b(5) + a(11) * b(8) + b(11)

End Sub

 

[weagan22]

I believe you need to make the copy after you set the second product active. The copy takes the axis system of the active product. This is a hard thing to wrap your head around but I can almost guarantee that origin (0,0,0 location) of the second product is different than the first one.