---

Hallo Programmierer ich habe wider mal eine Frage!
Kann mir jemand bitte sagen wie ich das folgende Makro schneller machen kann?
Ich bekomme CATPart´s mit bis zu 2000 Körpern und muß daraus CATProduct´s erstellen.
Also habe ich mir ein Makro gebastelt und es Funktioniert sogar einiger maßen.
Aber ab 400 Körpern im CATPart funktioniert es nicht mehr, weil es kontinuierlich langsamer wird.
Und mein zweites Problem ist wenn zwei Körper den gleichen Nahmen haben stürzt es ab.
Kann mir bitte jemand weiterhelfe oder hat jemand eine andere Lösung für mich?
Vorab schon einmal DANKE !
'------------------------------------------------------------
' Makroname = Copy PART zu PRODUCT.CATScript
' Version:  V5R19
' Konvertiert ein CATPart in ein CATProduct
' Alle Koerper werden in CATPart's konvertiert
' Erweiterung: Alle GeoSets werden auch in CATPart's kopiert
'------------------------------------------------------------
Language = "VBSCRIPT"
Dim KomponenteNeu As products
Dim KoerperName
Dim OpenKoerperName
Dim hybridBodies As document
Dim Koerper  As Object
Dim QuellFenster As Window
Dim Letztekoerper
Dim UserSel As Selection
Sub CATMain()
Dim Activdocu As document
Set Activdocu = CATIA.ActiveDocument
    '---------------------------------------------------
    ' 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
    Dim partBodies As Bodies
    Set partBodies = Activdocu.Part.Bodies
    Dim koerperAnzahl
    koerperAnzahl = partBodies.Count
    Dim UserSel As Object
    For I = 1 To koerperAnzahl
        Set Koerper = partBodies.Item(I)
        KoerperName = Koerper.Name
        If Right(KoerperName, 1) = "\" Then
            KoerperName = Left(KoerperName, Len(KoerperName) - 1)
        End If
        KoerperName = Replace(KoerperName, "\", "_")
        '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", CStr(KoerperName))
        ' Fenster mit neue Product activieren
        ProductNeu.parent.Activate
        ' Alle Parts suchen
        PartSuchen ProductNeu.parent, UserSel
        ProductNeu.Parent.Selection.Clear
        ProductNeu.Parent.Selection.Add ProductNeu.products.Item(PartNeu).ReferenceProduct.Parent.Part
        ProductNeu.parent.Selection.Paste
        ProductNeu.parent.Selection.Clear
    Next
    Dim hybridBodies As hybridBodies
    Set hybridBodies = Activdocu.Part.hybridBodies
    koerperAnzahl = hybridBodies.Count
    For I = 1 To koerperAnzahl
        Set Koerper = hybridBodies.Item(I)
        KoerperName = Koerper.Name
        If Right(KoerperName, 1) = "\" Then
            KoerperName = Left(KoerperName, Len(KoerperName) - 1)
        End If
        KoerperName = Replace(KoerperName, "\", "_")
        'Koerper kopieren
        Activdocu.Selection.Clear
        Activdocu.Selection.Add Koerper
        Activdocu.Selection.Copy
        Activdocu.Selection.Clear
        'Part erzeugen und Koerper einfuegen
        Set PartNeu = ProductNeu.products.AddNewComponent("Part", CStr(KoerperName))
        ' Fenster mit neue Product activieren
        ProductNeu.parent.Activate
        ' Alle Parts suchen
        PartSuchen ProductNeu.parent, UserSel
        ProductNeu.Parent.Selection.Clear
        ProductNeu.Parent.Selection.Add ProductNeu.products.Item(PartNeu).ReferenceProduct.Parent.Part
        ProductNeu.parent.Selection.Paste
        ProductNeu.parent.Selection.Clear
    Next
    ' Product actualisieren
    ProductNeu.ApplyWorkMode DESIGN_MODE
    On Error Resume Next
    ProductNeu.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 PartSuchen(oPartDoc1, UserSel)
    Dim E As Object 'CATBSTR
    Dim Was(0)
    Was(0) = "Part"
    Set UserSel = oPartDoc1.Selection
    UserSel.Clear
    UserSel.Search ("CATPrtSearch.PartFeature,all")
End Sub
Sub FensterNebeneinander()
    Dim windows1 As Windows
    Set windows1 = CATIA.Windows
    windows1.Arrange catArrangeTiledVertical
End Sub

------------------
MFG
ZORG

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

---

Hallo Zorg,

1. wenn zwei CATParts dieselbe Teilenummer bekommen, geht das nicht. Ich nehme an, das deswegen dein Programm abstürzt. Das musst du verhindern. Entweder das I an die Teilenummer anhängen, oder die Namen nach Gleichheit durchsuchen bevor du das Product erzeugst.

2. Dass der Speicher vollläuft ist nichts Neues. Das einzige was wirklich hilft, ist ein Neustart. (Meines Wissens)

------------------
-----------

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

---

Hallo noir333 !
Entschuldige bitte die späte Antwort, war auf Urlaub.

Erstens DANKE für Deine INFO.
Hast Du oder jemand Anders eine Idee wie ein Makro aussehen muß, mit dem ich einen fortlaufende Nummer an jeden Körper anhängen kann? Ich glaube das währe der Sicherste Weg um das Namensproblem zu lösen. ( Einfach Körper.1  - Körper .2 ----- usw. )

Zum Speichervollauf habe ich so eine Idee, kann sie leider nicht richtig umsetzen.
Kann es sein das der Speicher vollauft, weil das Product erst nach Abschluß des Kopierens ein Update durchführt?
Ich habe schon einmal versucht nach jeweils 100 Körpern ein Update des Product durchzuführen. (Leider habe ich kein Funktionierendes Makro geschafft.)

Mit freundlichen Grüßen und DANKE!

------------------
MFG
ZORG

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

---

Ohne in den Code en detail eingestiegen zu sein, hilft es bei fast allen Makros, den Bildschirmaufbau zeitweilig auszuschalten:

Code:

---

CATIA.RefreshDisplay = False
' dein Code
CATIA.RefreshDisplay = True

---

Mit Hilfe des iterierenden Zählers kannst Du den Namen Deines Körpers anpassen

Code:

---

For I = 1 To koerperAnzahl
Set Koerper = hybridBodies.Item(I)
KoerperName = Koerper.Name & I

---

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

---

Hallo der-quest
Danke für Deine Tips.

Das Namensproblem konnte ich Dank Dir lösen.
Weiters habe ich versucht den Bildschirmaufbau auszuschalten. Leider funktioniert es nicht oder ich habe die Falsche Position in meinem Code. ( Ich sehe noch immer im Product wie die einzelnen Teile hereinkommen. )
Trotzdem DANKE und vielleicht schaffe ich es noch den Bildschirmaufbau auszuschalten.

------------------
MFG
ZORG

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