---

Hallo Leute,

folgendes Makro soll mir aus den Einzelkörpern einen CATPART ein entsprechendes CATPRODUCT erstellen.

'------------------------------------------------------------
' Makroname = KopyPARTtoPRODUCT.CATScript
'
'
' Author: Filippo Gozza
' Version: V5R10, V5R12
'------------------------------------------------------------
' Konvertiert ein CATPart in ein CATProduct
' Alle Körper werden in CATPart's konvertiert
'------------------------------------------------------------

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" )

Letztekoerper = UserSel.Count

End Sub

Sub FensterNebeneinander()

Dim windows1 As Windows
Set windows1 = CATIA.Windows

windows1.Arrange catArrangeTiledVertical

End Sub

Habe es im I-net gefunden, aber mit meinen begrenzten Mitteln konnte ichŽs nicht beheben 
Falls einer Rat weiss: Danke im vorraus.

------------------
SuFu wurde immer benutzt, jedoch ohne den gewünschten Erfolg!

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Hallo Jensch,

hier ist eine neuere Version.
http://ww3.cad.de/foren/ubb/uploads/emphasis/PARTtoPRODUCT.CATScript.txt

Ciao,
Filippo

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Hallo Zusammen,

ich habe noch ein ähnliches Script gefunden, Credits an F.Harnatt, welches für mich etwas besser ist, da auch die Baugruppen erstellt werden. Kann mir hier ggf. jemand helfen wie ich das Script anpassen kann, so dass es kein neues Part erstellt, sondern ein Startpart aus einem bestimmten Pfad benutzt?
Ich habe von VBA leider keine Ahnung und weiß nicht wo ich anfangen soll zu suchen.

Code:

---

Option Explicit

Private Const cstStrMacroName As String = "Generate Product from AllCATPart"  ' wird z.B. als Titel in Msgboxen verwendet
Private Const cstStrMacroVersion As String = "v1.0"              ' Versionsnummer bei Änderungen immer erhöhen; Format v0.1 immer beibehalten
Private Const cstStrMacroAuthor As String = "F.Harnatt"

Dim objGroupNoShow As Group

Sub CATMain()
Dim objRootDocument As Document
Dim objDestProduct As Product
Dim objGroups As Groups

    ' Sicherstellen, dass das aktive Dokument ein Part ist...
    Set objRootDocument = CATIA.ActiveDocument
    If (TypeName(objRootDocument) <> "PartDocument") Then
        MsgBox _
            "The active Document has to be a Part (AllCATPart). Macro will be terminated." & Chr(13) & Chr(13) & _
            "Das aktive Dokument muss ein Part (AllCATPart) sein. Das Makro wird beendet.", _
            vbCritical Or vbApplicationModal Or vbOKOnly, _
            cstStrMacroName & " " & cstStrMacroVersion & " [(c) " & cstStrMacroAuthor & "]"
        Exit Sub
    Else
        ' kurze Info ausgeben
        If (vbCancel = MsgBox( _
            "This macro will convert the active document to a product structure (geometry" & Chr(13) & _
            "is copied as result). Do you want to proceed?" & Chr(13) & Chr(13) & _
            "Das Makro wird das aktive Dokument in eine Produktstruktur überführen" & Chr(13) & _
            "(Geometrie wird 'as Result' kopiert). Wollen Sie fortfahren?", _
            vbQuestion Or vbApplicationModal Or vbOKCancel, _
            cstStrMacroName & " " & cstStrMacroVersion & " [(c) " & cstStrMacroAuthor & "]")) Then Exit Sub
    End If
   
    ' das neue Product anlegen und benennnen...
    Set objDestProduct = CATIA.Documents.Add("Product").Product
    On Error Resume Next
    objDestProduct.PartNumber = Replace(objRootDocument.Product.PartNumber, "_AllCATPart", "", 1, -1, vbTextCompare) & "__FromAllCATPart"
    On Error GoTo 0

    ' NoShow-Group erzeugen
    Set objGroups = objDestProduct.GetTechnologicalObject("Groups")
    Set objGroupNoShow = objGroups.Add()
    objGroupNoShow.Name = "invisible Geometry"

    ' alle Bodies auflösen...
    processPartElementCollection objRootDocument, objDestProduct, objRootDocument.Part.Bodies
    processPartElementCollection objRootDocument, objDestProduct, objRootDocument.Part.HybridBodies
   
    ' Group mit unsichtbarer Geometrie löschen, wenn leer oder ausblenden
    If (objGroupNoShow.CountExplicit = 0) Then
        ' Gruppe leer -> löschen
        objGroups.Remove objGroupNoShow
    Else
        ' Gruppe nicht leer -> alles in NoShow
        objDestProduct.ReferenceProduct.Parent.Selection.Clear
        objDestProduct.ReferenceProduct.Parent.Selection.Add objGroupNoShow
        objDestProduct.ReferenceProduct.Parent.Selection.VisProperties.SetShow catVisPropertyNoShowAttr
    End If
   
    ' Shapes für erzeugtes Product laden und Instanzen benennen
    objDestProduct.ActivateDefaultShape 'todo
    renameInstancesInProduct objDestProduct, False
   
    ' erstellte Constraints in NoShow
    objDestProduct.ReferenceProduct.Parent.Selection.Clear
    objDestProduct.ReferenceProduct.Parent.Selection.Search "(CATAsmSearch.MfFixConstraint + CATSketchSearch.MfFixConstraint + CATDrwSearch.MfFixConstraint),all"
    objDestProduct.ReferenceProduct.Parent.Selection.VisProperties.SetShow catVisPropertyNoShowAttr
    ' Achsensysteme in NoShow
    objDestProduct.ReferenceProduct.Parent.Selection.Clear
    objDestProduct.ReferenceProduct.Parent.Selection.Search "(FreeStyle.'Axis System' + 'Part Design'.'Axis System' + 'Generative Shape Design'.'Axis System' + 'Functional Molded Part'.'Axis System'),all"
    objDestProduct.ReferenceProduct.Parent.Selection.VisProperties.SetShow catVisPropertyNoShowAttr
    ' Planes in NoShow
    objDestProduct.ReferenceProduct.Parent.Selection.Clear
    objDestProduct.ReferenceProduct.Parent.Selection.Search "(((CATStFreeStyleSearch.Plane + CATPrtSearch.Plane) + CATGmoSearch.Plane) + CATSpdSearch.Plane),all"
    objDestProduct.ReferenceProduct.Parent.Selection.VisProperties.SetShow catVisPropertyNoShowAttr
   
    'Selektions löschen
    objDestProduct.ReferenceProduct.Parent.Selection.Clear
    objRootDocument.Selection.Clear
   
    ' erstelltes Produkt updaten und Reframe ausführen
    objDestProduct.Update
    CATIA.ActiveWindow.ActiveViewer.Reframe
End Sub

Private Sub processPartElementCollection(objRootDocument As Document, objDestProduct As Product, colPartElements)
Dim objTmpParentProduct As Product
Dim objNewPartProduct As Product
Dim intCurrentComponent As Integer
Dim strUniqueComponentNamePrefix As String
Dim strNameCurrentComponent As String
Dim arrStrComponents'() As String
Dim valVisProperty As CatVisPropertyShow

    strUniqueComponentNamePrefix = Date & "_" & Time
    For intCurrentComponent = 1 To colPartElements.Count
        ' vollständigen Namen der Komponente ermitteln
        strNameCurrentComponent = colPartElements.Item(intCurrentComponent).Name
        If Right(strNameCurrentComponent, 1) = "\" Then strNameCurrentComponent = Left(strNameCurrentComponent, Len(strNameCurrentComponent) - 1)
        strNameCurrentComponent = Replace(strNameCurrentComponent, "\PartBody", "")
       
        ' Produktstruktur rekonstruieren
        arrStrComponents = Split(strNameCurrentComponent, "\", -1, vbTextCompare)
        Set objTmpParentProduct = createProductStructureWithComponents(objDestProduct, arrStrComponents)
        ' Namen für Part ermitteln
        strNameCurrentComponent = arrStrComponents(UBound(arrStrComponents))
       
        ' Body kopieren
        objRootDocument.Selection.Clear
        objRootDocument.Selection.Add colPartElements.Item(intCurrentComponent)
        objRootDocument.Selection.Copy
       
        ' Part erzeugen, benennen und fixieren
        Set objNewPartProduct = objTmpParentProduct.Products.AddNewComponent("Part", strUniqueComponentNamePrefix & "__" & Right("0000" & CStr(intCurrentComponent), 4))
        setUniquePartName objNewPartProduct, strNameCurrentComponent
        objDestProduct.Parent.GetItem(objTmpParentProduct.PartNumber).ReferenceProduct.Connections("CATIAConstraints").AddMonoEltCst( _
            catCstTypeReference, _
            objDestProduct.Parent.GetItem(objTmpParentProduct.PartNumber).CreateReferenceFromName(getUniqueInstanceName(objNewPartProduct) & "/!" & getUniqueInstanceName(objNewPartProduct) & "/") _
        ).ReferenceType = catCstRefTypeFixInSpace

        ' Geometerie aus Zwischenablage einfügen
        objDestProduct.Parent.Selection.Clear
        objDestProduct.Parent.Selection.Add objTmpParentProduct.Products.Item(objNewPartProduct).ReferenceProduct.Parent.Part
        objDestProduct.Parent.Selection.PasteSpecial "CATPrtResultWithOutLink"
        ' Terminal Node aktivieren
        objTmpParentProduct.Products.Item(objNewPartProduct.Name).ActivateDefaultShape
       
        ' ggf. in NoShow-Gruppe hinzufügen
        objRootDocument.Selection.VisProperties.GetShow valVisProperty
        If (valVisProperty = catVisPropertyNoShowAttr) Then
            ' zur Gruppe hinzufügen
            objGroupNoShow.AddExplicit objNewPartProduct
            ' Geometrie einblenden (später wird die Gruppe mit allen ihren Parts ausgeblendet)
            objDestProduct.Parent.Selection.VisProperties.SetShow catVisPropertyShowAttr
        End If
    Next
End Sub

Private Function createProductStructureWithComponents(objDestProduct As Product, arrStrComponents() As String) As Product
Dim intCurrentComponent As Integer
Dim objTmpProduct As Product
Dim bolProductExists As Boolean

    On Error Resume Next
    Set objTmpProduct = objDestProduct
    For intCurrentComponent = LBound(arrStrComponents) To UBound(arrStrComponents) - 1
        ' prüfen, ob ein entsprechendes Product bereits existiert
        bolProductExists = (objTmpProduct.Products.Item(arrStrComponents(intCurrentComponent) & ".1").Name <> "")
        If (bolProductExists = True) Then
            ' Product exisstiert -> merken
            Set objTmpProduct = objTmpProduct.Products.Item(arrStrComponents(intCurrentComponent) & ".1")
        Else
            ' Product existiert nicht -> anlegen
            Set objTmpProduct = objTmpProduct.Products.AddNewProduct(arrStrComponents(intCurrentComponent))
            ' und fixieren
            objDestProduct.Parent.GetItem(objTmpProduct.Parent.Parent.PartNumber).ReferenceProduct.Connections("CATIAConstraints").AddMonoEltCst( _
                catCstTypeReference, _
                objDestProduct.Parent.GetItem(objTmpProduct.Parent.Parent.PartNumber).CreateReferenceFromName(getUniqueInstanceName(objTmpProduct) & "/!" & getUniqueInstanceName(objTmpProduct) & "/") _
            ).ReferenceType = catCstRefTypeFixInSpace
        End If
    Next
    On Error GoTo 0
   
    Set createProductStructureWithComponents = objTmpProduct
End Function

Private Sub setUniquePartName(objTmpProduct As Product, strNameCurrentComponent As String)
Dim strTmpComponentName As String
Dim intCurrentInstance As Integer

    strTmpComponentName = objTmpProduct.PartNumber
    On Error Resume Next
    While (objTmpProduct.PartNumber = strTmpComponentName)
        intCurrentInstance = intCurrentInstance + 1
        objTmpProduct.PartNumber = strNameCurrentComponent & "__inst" & Right("0000" & CStr(intCurrentInstance), 4)
    Wend
    On Error GoTo 0
End Sub

Private Sub renameInstancesInProduct(oRootProduct As Product, bolFirstRun As Boolean)
Dim intSubProductItem As Integer
Dim intSequenceNumber As Integer
Dim intItem As Integer
Dim bolInstNameUnique As Boolean
Dim strNewInstanceName As String
Dim oSubProducts As Products
Dim oPartToRenameTheInstance As Product

    Set oSubProducts = oRootProduct.Products

    ' Array für Instance-Names aller untergeordneten Elemente erstellen
    ReDim arrStrInstNames(oSubProducts.Count) As String
   
    ' alle untergeordneten Elemente durchlaufen
    For intSubProductItem = 1 To oSubProducts.Count
        ' je nach Parameter das aktuelle Element umbenennen
        If (bolFirstRun = True) Then
            ' erster Durchlauf -> einfach die fortlaufende Item-Number mit Zeitstempel als Instanz-Name verwenden
            Set oPartToRenameTheInstance = oSubProducts.Item(intSubProductItem)
            oPartToRenameTheInstance.Parent.Parent.ReferenceProduct.Products.Item(oPartToRenameTheInstance.Name).Name = intSubProductItem & "__" & Date & "_" & Replace(Time, ":", "-")
        Else
            ' zweiter Durchlauf -> InstanceName aus Partname mit fortlaufender Nummer erstellen
            intSequenceNumber = 0
           
            ' im aktuellen Kontext eindeutigen Instanz-Namen erstellen
            bolInstNameUnique = False
            Do While (bolInstNameUnique = False)
                ' Namen nach Schema generieren
                intSequenceNumber = intSequenceNumber + 1
                strNewInstanceName = oSubProducts.Item(intSubProductItem).PartNumber & "." & intSequenceNumber

                ' jetzt davon ausgehen, dass er unique ist
                bolInstNameUnique = True
                ' und alle bisher gesetzten Namen durchgehen
                For intItem = 1 To intSubProductItem - 1
                    ' prüfen, ob es eine Übereinstimmung gibt und ggf. die Hilfsvariable neu setzen
                    If ((bolInstNameUnique = True) And (strNewInstanceName = arrStrInstNames(intItem))) Then
                        bolInstNameUnique = False
                    End If
                Next
            Loop

            ' eindeutigen generierten Instanz-Namen merken
            arrStrInstNames(intSubProductItem) = strNewInstanceName

            ' und der Instanz zuweisen
            Set oPartToRenameTheInstance = oSubProducts.Item(intSubProductItem)
            oPartToRenameTheInstance.Parent.Parent.ReferenceProduct.Products.Item(oPartToRenameTheInstance.Name).Name = strNewInstanceName
        End If
       
        ' wenn es mehr als ein Unterobjekt gibt, dann ist es ein Produkt
        If (oSubProducts.Item(intSubProductItem).Products.Count > 0) Then
            ' also muss man die Funktion rekursiv aufgerufen werden
            renameInstancesInProduct oSubProducts.Item(intSubProductItem), bolFirstRun
        End If
    Next
End Sub

' liefert für eine Instanz den kompletten Instanz-Namen bis zum Root-Knoten
' wichtig, um bei identischen Instanznamen die richtige Instanz zu finden
Private Function getUniqueInstanceName(objTmpProductInstance As Product) As String
Dim strUniqueInstanceName As String
Dim objTmpParentProduct As Product

    strUniqueInstanceName = objTmpProductInstance.Name
    If (TypeName(objTmpProductInstance.Parent.Parent) = "Product") Then
        Set objTmpParentProduct = objTmpProductInstance.Parent.Parent
   
        While (TypeName(objTmpParentProduct) = "Product")
            strUniqueInstanceName = objTmpParentProduct.Name & "/" & strUniqueInstanceName
            ' eine Ebene weiter vor
            If (TypeName(objTmpParentProduct.Parent.Parent) = "Product") Then Set objTmpParentProduct = objTmpParentProduct.Parent.Parent _
            Else Set objTmpParentProduct = Nothing
        Wend
    End If
   
    getUniqueInstanceName = strUniqueInstanceName
End Function

---

------------------
Click OK to terminate

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP