на просторах интернета наткнулся на такой скрипт и хочу немного его изменить, но в виду отсутствия опыта и нехватки знаний не получается(((
скрипт генерит из каждого бои отдельный парт и сразу собирает в сборку - и это замечательно. НО нужно чтобы он генерил ТОЛЬКО те боди, которые show
- Код: Выделить всё
' ------------------------------------------------- -----------
' Converts a CATPart in a CATProduct
' All body are converted into CATPart 's
' All GeoSets be copied in CATPart 's
' ------------------------------------------------- -----------
' Language = " VBSCRIPT"
Dim ComponentNew As Products
Dim BodyName
Dim OpenBodyName
Dim hybridbodies As Document
Dim body As Object
Dim sourcewindow As Window
Dim Lastbody
Dim UserSel As Selection
Sub CATMain ()
Dim Activdocu As Document
Set Activdocu = CATIA.ActiveDocument
' ------------------------------------------------- -
'New Product
' ------------------------------------------------- -
Dim PosString As Long
partName = CATIA.ActiveDocument.Name
Dim docu As Documents
Set docu = CATIA.Documents
Dim productDocu As Document
Set productDocu = docu.Add ("Product")
Dim ProductNew As Product
Set ProductNew = productDocu.Product
PosString = InStr (1 , partname, ".CATPart")
ProductNew.PartNumber = Mid(partname, 1, PosString - 1)
' ------------------------------------------------- -----
Windowssidebyside
Set Sourcewindow = CATIA.Windows.Item (1)
SourceWindow.Activate
Dim partbodies As Bodies
'Set Activdocu = CATIA.ActiveDocument
Set partbodies = Activdocu.Part.Bodies
Dim bodynumber
bodynumber = partBodies.Count
Dim UserSel As Object
Dim PartNew As Product
Dim workpart As PartDocument
For i = 1 To bodynumber
Set body = partBodies.Item (i)
BodyName = Body.Name
If Right (BodyName , 1) = " \ " Then
BodyName = Left (BodyName , Len (BodyName) - 1)
end If
BodyName = Replace (BodyName , "\ ", " _")
'Copy body
Activdocu.Selection.Clear
Activdocu.Selection.Add body
Activdocu.Selection.Copy
Activdocu.Selection.Clear
'Create Part and Paste body
On Error Resume Next
Set PartNew = ProductNew.Products.AddNewComponent ( "Part" , CStr ( BodyName ) )
If Err.Number <> 0 Then
On Error GoTo 0
l = ProductNew.Products.Count
Set PartNew = ProductNew.Products.Item (i)
BodyName = BodyName & "." & i
BodyName = BodyName
PartNew.PartNumber = BodyName
end If
'Activate window with new Product
ProductNew.Parent.Activate
'Search All Parts
PartSearch ProductNew.Parent , UserSel
' ProductNew.parent.Selection.Clear
' ProductNew.parent.Selection.Add UserSel.Item ( UserSel.Count ) .Value
ProductNew.Parent.Selection.Clear
ProductNew.Parent.Selection.Add ProductNew.Products.Item(PartNew).ReferenceProduct.Parent.Part
ProductNew.Parent.Selection.PasteSpecial "CATPrtResult"
ProductNew.Parent.Selection.Clear
' make inserted body to PartBody and delete ex- PartBody
Set workpart = ProductNew.Products.Item(PartNew).ReferenceProduct.Parent
workPart.Part.MainBody = workPart.Part.Bodies.Item(workPart.Part.Bodies.Count)
ProductNew.Parent.Selection.Add workPart.Part.Bodies.Item (1)
ProductNew.Parent.Selection.Delete
ProductNew.Parent.Selection.Clear
Next
Dim hybridbodies As hybridbodies
' Set Activdocu = CATIA.ActiveDocument
Set hybridbodies = Activdocu.Part.hybridBodies
bodyNumber = hybridBodies.Count
For i = 1 To BodyNumber
Set body = hybridBodies.Item (i)
BodyName = Body.Name
If Right (BodyName , 1) = " \ " Then
BodyName = Left(BodyName , Len(BodyName ) - 1)
end If
BodyName = Replace ( BodyName , "\ ", " _")
' Copy body
Activdocu.Selection.Clear
Activdocu.Selection.Add body
Activdocu.Selection.Copy
Activdocu.Selection.Clear
'Create Part and Paste body
Set PartNew = ProductNew.Products.AddNewComponent("Part" , CStr ( BodyName ) )
'Activate window with new Product
ProductNew.Parent.Activate
' Search All Parts
PartSearch ProductNew.Parent, UserSel
'ProductNew.parent.Selection.Clear
'ProductNew.parent.Selection.Add UserSel.Item(UserSel.Count) .Value
ProductNew.Parent.Selection.Clear
ProductNew.Parent.Selection.Add ProductNew.Products.Item(PartNew).ReferenceProduct.Parent.Part
ProductNew.Parent.Selection.PasteSpecial "CATPrtResultWithOutLink "
ProductNew.Parent.Selection.Clear
Next
' Update Product
ProductNew.ApplyWorkMode DESIGN_MODE
On Error Resume Next
ProductNew.Update
If Err <> 0 Then
MsgBox " Problem with update!" & VbLf & vbLf & " Please update manual ", vbCritical + vbOKOnly, "Update Error"
end If
On Error GoTo 0
end Sub
Sub PartSearch(oPartDoc1 , UserSel )
Dim E As Object 'CATBSTR
Dim What( 0)
What(0) = "Part"
' Dim UserSel As Object
Set UserSel = oPartDoc1.Selection
UserSel.Clear
' Let us first fill the CSO with all the objects of the model
UserSel.Search ("CATPrtSearch.PartFeature,all" )
' E = UserSel.SelectElement2(What, " All CATPart w ?Choose", True )
' LastBody = UserSel.Count
End Sub
Sub windowssidebyside ()
Dim windows1 As Windows
Set windows1 = CATIA.Windows
windows1.Arrange catArrangeTiledVertical
end Sub
