mutli
Automotive
- Oct 30, 2012
- 5
Hello to all,
I have macro for copying bodys from selected parts to target part (it also publicate bodys inside all selected parts and paste with link into target part do assamble and symmetry)
So at the end it creates symmetry of product but in part.
I am new to catia vba and all of this code is combined from diferent macros
Problem is with instances . it copy all instances at th same place.
I hope someone could help me with this, a am ata the wall
Here is my code and shema of my product.
thanks in advance
Sub CATMain()
On Error Resume Next
Dim ActiveDocument1 As Document
Set ActiveDocument1 = CATIA.ActiveDocument
If Err.Number <> 0 Then
' in case no open document was found
' ...
'''Err.Clear
Call MsgBox("No document was found.", _
vbCritical + vbOKOnly, "Error")
Exit Sub
End If
Dim Selection1 As Selection
Dim sel As Selection
Dim cSelection 'As Selection
Dim cSel As Selection
Dim oProd As Product
Dim oObject As Object
Dim Sa As String
Dim i As Integer
Dim n As Integer
Dim V As Integer
Dim targetPart As String
Dim StatusPart As String
Dim Status As String
Dim InputObjectType(0)
Dim srcDoc As PartDocument
Dim srcPart As Part
Dim srcPart2 As Part
Dim body1 As Body
Dim B As Integer
Dim Bodies1 As Bodies
Dim GBool As Boolean
Dim NBool As Boolean
Set Selection1 = ActiveDocument1.Selection
Set sel = ActiveDocument1.Selection
V = Selection1.Count
If Selection1.Count = 0 Then
MsgBox "Markieren Sie die Teile zum kopiren:" & vbCrLf, vbCritical
Exit Sub
End If
If Selection1.Count2 > 0 Then
For D = 1 To Selection1.Count2
Set oObject = Selection1.Item(D).Value
Select Case Selection1.Item(D).Type
Case Is = "Product"
MsgBox oObject.Product
Case Else:
MsgBox "Nur die Teile Markiren!"
Exit Sub
End Select
Next D
Else
MsgBox "Teile Markieren:" & vbCrLf, vbCritical
Exit Sub
End If
'MsgBox V
'Exit Sub
If Selection1.Count <> 0 Then
Dim product1 As Product
Dim strFriends(0 To 200) As String
For i = 1 To Selection1.Count
Set product1 = Selection1.Item(i).Value
strFriends(i) = product1.PartNumber
StatusPart = ""
Set srcDoc = CATIA.Documents.Item(strFriends(i) & ".CATPart")
StatusPart = srcDoc.Name
If StatusPart = "" Then
MsgBox "Nur die Teile Markiren!", vbInformation, "Error"
Exit Sub
End If
Next
'-------------------------------------------------------------------------------------------------------------
Dim oDoc1 As Document
Set oDoc1 = CATIA.ActiveDocument
MsgBox "Catpart wählen:"
Set cSelection = oDoc1.Selection
cSelection.Clear
InputObjectType(0) = "AnyObject"
Status = cSelection.SelectElement2(InputObjectType, "Select an Element", True)
If (Status = "Cancel") Then
MsgBox "CATPart nicht gewählt!", vbInformation, "Error"
Exit Sub
Else
Set oObject = cSelection.Item(1).Value
cSelection.Clear
targetPart = oObject.Name & ".CATPart"
Dim Startabfrage As Integer
Startabfrage = MsgBox("Gewähltes Catpart nahmen? " & targetPart, 1 + 64, "")
If Startabfrage = 2 Then
Exit Sub
End If
'----------------------------------------------------------------------------------------
' For i = 1 To V
' Set srcDoc = CATIA.Documents.Item(strFriends(i) & ".CATPart")
' srcDoc.Activate
' Set srcPart = srcDoc.Part
' Set Bodies1 = srcPart.Bodies
' For B = 1 To srcPart.Bodies.Count
' If Bodies1.Item(B).InBooleanOperation = False Then
' Set body1 = Bodies1.Item(B)
' GBool = False
' Set documents1 = CATIA.Documents
' Set partDocument1 = documents1.Item(strFriends(i) & ".CATPart")
' Set product5 = partDocument1.GetItem(strFriends(i))
' Set reference1 = product5.CreateReferenceFromName(strFriends(i) & "/!" & body1.Name)
' Set publications1 = product5.Publications
' For Z = 1 To publications1.Count
' 'MsgBox publications1.Item(Z).Name
' If publications1.Item(Z).Name = body1.Name Then
' GBool = True
' End If
' Next Z
' If GBool = False Then
' Set publication1 = publications1.Add(body1.Name)
' publications1.SetDirect body1.Name, reference1
'' End If
' End If
' Next
' Next
'-------------------------------------------------------------------------------------------------------------------
Dim NazivBody As String
Dim NazivBody1 As String
Dim TV As Integer
For i = 1 To V
Set srcDoc = CATIA.Documents.Item(strFriends(i) & ".CATPart")
srcDoc.Activate
Set srcPart = srcDoc.Part
Set Bodies1 = srcPart.Bodies
For B = 1 To srcPart.Bodies.Count
If Bodies1.Item(B).InBooleanOperation = False Then
Set body1 = Bodies1.Item(B)
GBool = False
NBool = False
Set documents1 = CATIA.Documents
NazivBody = body1.Name
If Len(body1.Name) > 8 Then
If Right(body1.Name, 8) = "PartBody" Then
body1.Name = body1.Name & "1"
NBool = True
End If
End If
Set partDocument1 = documents1.Item(strFriends(i) & ".CATPart")
Set product5 = partDocument1.GetItem(strFriends(i))
Set reference1 = product5.CreateReferenceFromName(strFriends(i) & "/!" & body1.Name)
Set publications1 = product5.Publications
For Z = 1 To publications1.Count
'MsgBox publications1.Item(Z).Name
If publications1.Item(Z).Name = body1.Name Then
GBool = True
End If
Next Z
If GBool = False Then
Set publication1 = publications1.Add(body1.Name)
publications1.SetDirect body1.Name, reference1
End If
If NBool = True Then
body1.Name = NazivBody
End If
sel.Clear
sel.Add Bodies1.Item(B)
sel.Copy
Dim targetDoc As PartDocument
Set targetDoc = CATIA.Documents.Item(targetPart)
sel.Clear
Set specsAndGeomWindow1 = CATIA.ActiveWindow
Set srcPart2 = targetDoc.Part
sel.Add srcPart2
sel.PasteSpecial ("CATPrtResult")
srcPart2.Update
'MsgBox body1.Name
End If
Next
Next
'----------------------------------------------------------------------------------------------------------------------
Set targetDoc = CATIA.Documents.Item(targetPart)
' MsgBox targetDoc.Name
targetDoc.Activate
Set srcPart = targetDoc.Part
Set Bodies1 = srcPart.Bodies
n = Bodies1.Count
Set body1 = Bodies1.Item("PartBody") 'The fisrt body of my CATPart
Dim shapeFactory1 As Factory
Set shapeFactory1 = srcPart.ShapeFactory
For i = 2 To n
If Bodies1.Item(i).InBooleanOperation = False Then
srcPart.InWorkObject = body1
Dim body2 As Body
Set body2 = Bodies1.Item(i)
Dim assemble1 As Assemble
Set assemble1 = shapeFactory1.AddNewAssemble(body2)
End If
Next
srcPart.UpdateObject assemble1
srcPart.Update
Dim Symmetry1 As Symmetry
Set Symmetry1 = shapeFactory1.AddNewSymmetry2(body1)
srcPart.UpdateObject Symmetry1
srcPart.Update
MsgBox "Fertig"
End If
End If
End Sub
I have macro for copying bodys from selected parts to target part (it also publicate bodys inside all selected parts and paste with link into target part do assamble and symmetry)
So at the end it creates symmetry of product but in part.
I am new to catia vba and all of this code is combined from diferent macros
Problem is with instances . it copy all instances at th same place.
I hope someone could help me with this, a am ata the wall
Here is my code and shema of my product.
thanks in advance
Sub CATMain()
On Error Resume Next
Dim ActiveDocument1 As Document
Set ActiveDocument1 = CATIA.ActiveDocument
If Err.Number <> 0 Then
' in case no open document was found
' ...
'''Err.Clear
Call MsgBox("No document was found.", _
vbCritical + vbOKOnly, "Error")
Exit Sub
End If
Dim Selection1 As Selection
Dim sel As Selection
Dim cSelection 'As Selection
Dim cSel As Selection
Dim oProd As Product
Dim oObject As Object
Dim Sa As String
Dim i As Integer
Dim n As Integer
Dim V As Integer
Dim targetPart As String
Dim StatusPart As String
Dim Status As String
Dim InputObjectType(0)
Dim srcDoc As PartDocument
Dim srcPart As Part
Dim srcPart2 As Part
Dim body1 As Body
Dim B As Integer
Dim Bodies1 As Bodies
Dim GBool As Boolean
Dim NBool As Boolean
Set Selection1 = ActiveDocument1.Selection
Set sel = ActiveDocument1.Selection
V = Selection1.Count
If Selection1.Count = 0 Then
MsgBox "Markieren Sie die Teile zum kopiren:" & vbCrLf, vbCritical
Exit Sub
End If
If Selection1.Count2 > 0 Then
For D = 1 To Selection1.Count2
Set oObject = Selection1.Item(D).Value
Select Case Selection1.Item(D).Type
Case Is = "Product"
MsgBox oObject.Product
Case Else:
MsgBox "Nur die Teile Markiren!"
Exit Sub
End Select
Next D
Else
MsgBox "Teile Markieren:" & vbCrLf, vbCritical
Exit Sub
End If
'MsgBox V
'Exit Sub
If Selection1.Count <> 0 Then
Dim product1 As Product
Dim strFriends(0 To 200) As String
For i = 1 To Selection1.Count
Set product1 = Selection1.Item(i).Value
strFriends(i) = product1.PartNumber
StatusPart = ""
Set srcDoc = CATIA.Documents.Item(strFriends(i) & ".CATPart")
StatusPart = srcDoc.Name
If StatusPart = "" Then
MsgBox "Nur die Teile Markiren!", vbInformation, "Error"
Exit Sub
End If
Next
'-------------------------------------------------------------------------------------------------------------
Dim oDoc1 As Document
Set oDoc1 = CATIA.ActiveDocument
MsgBox "Catpart wählen:"
Set cSelection = oDoc1.Selection
cSelection.Clear
InputObjectType(0) = "AnyObject"
Status = cSelection.SelectElement2(InputObjectType, "Select an Element", True)
If (Status = "Cancel") Then
MsgBox "CATPart nicht gewählt!", vbInformation, "Error"
Exit Sub
Else
Set oObject = cSelection.Item(1).Value
cSelection.Clear
targetPart = oObject.Name & ".CATPart"
Dim Startabfrage As Integer
Startabfrage = MsgBox("Gewähltes Catpart nahmen? " & targetPart, 1 + 64, "")
If Startabfrage = 2 Then
Exit Sub
End If
'----------------------------------------------------------------------------------------
' For i = 1 To V
' Set srcDoc = CATIA.Documents.Item(strFriends(i) & ".CATPart")
' srcDoc.Activate
' Set srcPart = srcDoc.Part
' Set Bodies1 = srcPart.Bodies
' For B = 1 To srcPart.Bodies.Count
' If Bodies1.Item(B).InBooleanOperation = False Then
' Set body1 = Bodies1.Item(B)
' GBool = False
' Set documents1 = CATIA.Documents
' Set partDocument1 = documents1.Item(strFriends(i) & ".CATPart")
' Set product5 = partDocument1.GetItem(strFriends(i))
' Set reference1 = product5.CreateReferenceFromName(strFriends(i) & "/!" & body1.Name)
' Set publications1 = product5.Publications
' For Z = 1 To publications1.Count
' 'MsgBox publications1.Item(Z).Name
' If publications1.Item(Z).Name = body1.Name Then
' GBool = True
' End If
' Next Z
' If GBool = False Then
' Set publication1 = publications1.Add(body1.Name)
' publications1.SetDirect body1.Name, reference1
'' End If
' End If
' Next
' Next
'-------------------------------------------------------------------------------------------------------------------
Dim NazivBody As String
Dim NazivBody1 As String
Dim TV As Integer
For i = 1 To V
Set srcDoc = CATIA.Documents.Item(strFriends(i) & ".CATPart")
srcDoc.Activate
Set srcPart = srcDoc.Part
Set Bodies1 = srcPart.Bodies
For B = 1 To srcPart.Bodies.Count
If Bodies1.Item(B).InBooleanOperation = False Then
Set body1 = Bodies1.Item(B)
GBool = False
NBool = False
Set documents1 = CATIA.Documents
NazivBody = body1.Name
If Len(body1.Name) > 8 Then
If Right(body1.Name, 8) = "PartBody" Then
body1.Name = body1.Name & "1"
NBool = True
End If
End If
Set partDocument1 = documents1.Item(strFriends(i) & ".CATPart")
Set product5 = partDocument1.GetItem(strFriends(i))
Set reference1 = product5.CreateReferenceFromName(strFriends(i) & "/!" & body1.Name)
Set publications1 = product5.Publications
For Z = 1 To publications1.Count
'MsgBox publications1.Item(Z).Name
If publications1.Item(Z).Name = body1.Name Then
GBool = True
End If
Next Z
If GBool = False Then
Set publication1 = publications1.Add(body1.Name)
publications1.SetDirect body1.Name, reference1
End If
If NBool = True Then
body1.Name = NazivBody
End If
sel.Clear
sel.Add Bodies1.Item(B)
sel.Copy
Dim targetDoc As PartDocument
Set targetDoc = CATIA.Documents.Item(targetPart)
sel.Clear
Set specsAndGeomWindow1 = CATIA.ActiveWindow
Set srcPart2 = targetDoc.Part
sel.Add srcPart2
sel.PasteSpecial ("CATPrtResult")
srcPart2.Update
'MsgBox body1.Name
End If
Next
Next
'----------------------------------------------------------------------------------------------------------------------
Set targetDoc = CATIA.Documents.Item(targetPart)
' MsgBox targetDoc.Name
targetDoc.Activate
Set srcPart = targetDoc.Part
Set Bodies1 = srcPart.Bodies
n = Bodies1.Count
Set body1 = Bodies1.Item("PartBody") 'The fisrt body of my CATPart
Dim shapeFactory1 As Factory
Set shapeFactory1 = srcPart.ShapeFactory
For i = 2 To n
If Bodies1.Item(i).InBooleanOperation = False Then
srcPart.InWorkObject = body1
Dim body2 As Body
Set body2 = Bodies1.Item(i)
Dim assemble1 As Assemble
Set assemble1 = shapeFactory1.AddNewAssemble(body2)
End If
Next
srcPart.UpdateObject assemble1
srcPart.Update
Dim Symmetry1 As Symmetry
Set Symmetry1 = shapeFactory1.AddNewSymmetry2(body1)
srcPart.UpdateObject Symmetry1
srcPart.Update
MsgBox "Fertig"
End If
End If
End Sub