'------------------------------------------------------------ ' Makroname = KopyPARTtoPRODUCT.CATScript ' ' ' Author: Filippo Gozza ' Version: V5R10, V5R12 '------------------------------------------------------------ ' Konvertiert ein CATPart in ein CATProduct ' Alle Körper werden in CATPart's konvertiert ' www.3dcatia.com '------------------------------------------------------------ Language="VBSCRIPT" Dim KomponenteNeu As Products Dim KoerperName Dim OpenKoerperName Dim productDocument1 As Document Dim Koerper As Object Dim QuellFenster As Window Dim Letztekoerper Dim UserSel As Selection Sub CATMain() Dim Activdocu As Document '--------------------------------------------------- ' Neue 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 ProductNeu As Product Set ProductNeu = productDocu.Product PosString = InStr(1, PartName , ".CATPart") ProductNeu.PartNumber = Mid (PartName , 1 , PosString -1 ) '------------------------------------------------------ FensterNebeneinander() Set QuellFenster = CATIA.Windows.Item(1) QuellFenster.Activate Set Activdocu = CATIA.ActiveDocument Set productDocument1 = Activdocu.Part.Bodies Dim koerperAnzahl koerperAnzahl = productDocument1.count for i =1 to koerperAnzahl Set Koerper = productDocument1.Item(i) KoerperName = Koerper.Name 'Koerper kopieren Activdocu.Selection.clear Activdocu.Selection.Add Koerper Activdocu.Selection.Copy Activdocu.Selection.clear 'Part erzeugen und Koerper einfuegen Dim PartNeu As Product Set PartNeu = ProductNeu.Products.AddNewComponent("Part", KoerperName ) ' Fenster mit neue Product activieren ProductNeu.Parent.Activate ' Alle Parts suchen PartSuchen(ProductNeu.Parent) ProductNeu.Parent.Selection.Clear ProductNeu.Parent.Selection.Add UserSel.Item(Letztekoerper).Value ProductNeu.Parent.Selection.Paste ProductNeu.Parent.Selection.Clear next ' Product actualisieren ProductNeu.update End Sub Sub PartSuchen(oPartDoc1) Dim E As CATBSTR Dim Was (0) Was(0) = "Part" 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.SelectElement ( Was, "Alle CATPart wählen", true ) Letztekoerper = UserSel.Count End Sub Sub FensterNebeneinander() Dim windows1 As Windows Set windows1 = CATIA.Windows windows1.Arrange catArrangeTiledVertical End Sub