---

Hallo,

ich habe ein Makro geschrieben, welches aus einer Baugruppe heraus selektierte Parts und Products in eine neu erstellte Baugruppe kopiert. Parts werden dabei über die Methode Paste eingefügt und Products über PasteSpecial "CATSpecBreakLink".
Das ganze funktioniert auch wunderbar, jedoch würde ich das Makro gerne übersichtlicher gestalten und mit Unterroutinen versehen. Z.B. könnte man den Code unter '---Filter in einer Unterroutine zusammenfassen, ich weiß jedoch nicht wie man das Ganze dann deklariert bzw. welche Parameter bei der Unterroutine übergeben werden müssen.
Bin für jede Verbesserung dankbar .

Code:

---

Sub CATMain()

' Selektierte Elemente
Dim oSel
Set oSel = CATIA.ActiveDocument.Selection

' ---Produkt erzeugen
Set oProduct1 = CATIA.Documents.Add ("Product")
Set oProduct2 = oProduct1.Product

' ---Array deklarieren
Dim aArray ()
ReDim aArray (0)

If oSel.Count  > 0 Then

' ---Selektion Auslesen
For i = 1 to oSel.Count

' ---Wert dem Arrayfeld zuordnen
Set aArray(UBound(aArray)) = oSel.Item(i).Value
' ---Arraydimension um 1 Feld erweitern
ReDim Preserve aArray(UBound(aArray)+1)

Next

' ---Selektion löschen
oSel.Clear

' ---Arrayobjekte der Selektion hinzufügen
For j = 0 to UBound(aArray)-1

' ---Filter
Set oUserSel = aArray(j)
Set oSelElem = oUserSel.ReferenceProduct.Parent
ObjectType = Typename (oSelElem)

' ---Filter anwenden für Parts
If Objecttype = ("PartDocument") Then

oSel.Add(aArray(j))

End If

Next

If oSel.Count <> 0 Then

oSel.Copy
oSel.clear
oSel.Add oProduct2

oSel.Paste

End If

oSel.Clear

' ---Arrayobjekte der Selektion hinzufügen
For j = 0 to UBound(aArray)-1

' ---Filter
Set oUserSel = aArray(j)
Set oSelElem = oUserSel.ReferenceProduct.Parent
ObjectType = Typename (oSelElem)

' ---Filter anwenden für Products
If Objecttype = ("ProductDocument") Then

oSel.Add(aArray(j))

End If

Next

If oSel.Count <> 0 Then

oSel.Copy
oSel.Clear
oSel.Add oProduct2

oSel.PasteSpecial "CATSpecBreakLink"

End If

oSel.Clear

Else

MsgBox ("Kein Dokument Selektiert")

End If

End Sub

---

Guß Zwenne

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

---

Hallo  ,

anbei mal mein Code. Die Änderungen habe ich gleich im Code reingeschrieben. Bei Fragen kannst du dich einfach melden. Die Filteroutine ist jetzt eine Funktion. Das Array ist global deklariert da die Sub und die Funktion darauf zugreifen müssen.

Schönheitsfehler (Einrücken, Schleifeende, etc.) habe ich auch verbessert. ICh denke so lässt sich der Code schon ein wenig besser lesen. Des weiteren ist er ein wenig performanter geworden 

Code:

---

'Option Explicit

'***DAS ARRAY WIRD GLOBAL DEFINIERT SO KANN DIE FUNKTION AUCH DARAUF ZUGREIFEN
Private aArray() As Object

Sub CATMain()

' Selektierte Elemente
    Dim oSel
    Set oSel = CATIA.ActiveDocument.Selection
   
    '***HIER DIE SCHLEIFE GLEICH ZU MACHEN!!!
    '***WENN DU LÄNGERE CODES HAST WIRD ES SONST UNÜBERSICHTLICH DU DA NICHT MEHR SIEHST WO GENAU DIE SCHLEIFEN ZUGEHEN
    '***DER ABSATZ KOMMT NOCH VOR DEM NEUEN PRODUKT. SONST HAST DU SCHON EIN NEUES PRODUKT OFFEN UND DAS MAKRO BRICHT AB
    '***ANDERE LÖSUNG: WENN NOCH NICHTS SELEKTIERT IST DANN KANN DER ANWENDER EIN PRODUKT/PART SELEKTIEREN!!!
    If oSel.Count = 0 Then
        MsgBox ("Kein Dokument Selektiert")
        Exit Sub
    End If
   
    ' ---Produkt erzeugen
    Set oProduct1 = CATIA.Documents.Add("Product")
    Set oProduct2 = oProduct1.Product
       
    ' ---Selektion Auslesen
    '***REDIM PRESERVE LEGT JEDES MAL EINE KOPIE VON SICH SELBER IM ARBEITSSPEICHER AN!!!
    '***DAS IST AUF DIE DAUER (IN SCHLEIFEN) NICHT PERFORMANT
    ReDim Preserve aArray(oSel.Count - 1)
    For i = 1 To oSel.Count
        ' ---Wert dem Arrayfeld zuordnen
        Set aArray(i - 1) = oSel.Item(i).Value
    Next

    ' ---Selektion löschen
    oSel.Clear

    ' ---Arrayobjekte der Selektion hinzufügen
    For j = 0 To UBound(aArray)
        '***WIRD GEBRAUCHT FALLS DAS OBJEKT LEER IST UND NICHTS ZUR SELEKTION HINZUGEFÜGT WIRD!!!
        On Error Resume Next
        oSel.Add FilterFunc(j, "PartDocument")
        On Error GoTo 0
    Next

    '***Kopieren und Einfügen
    If oSel.Count <> 0 Then
        oSel.Copy
        oSel.Clear
        oSel.Add oProduct2
        oSel.Paste
    End If

    oSel.Clear

    ' ---Arrayobjekte der Selektion hinzufügen
    For j = 0 To UBound(aArray)
        '***WIRD GEBRAUCHT FALLS DAS OBJEKT LEER IST UND NICHTS ZUR SELEKTION HINZUGEFÜGT WIRD!!!
        On Error Resume Next
        oSel.Add FilterFunc(j, "ProductDocument")
        On Error GoTo 0
    Next

    '***Kopieren und Einfügen
    If oSel.Count <> 0 Then
        oSel.Copy
        oSel.Clear
        oSel.Add oProduct2
        oSel.PasteSpecial "CATSpecBreakLink"
    End If

    oSel.Clear

End Sub

Private Function FilterFunc(ByVal uebArrayCounterInt As Integer, ByVal uebObjTypeStr As String) As Object
'***DEKLARATIONEN
    Dim oUserSel
    Dim oSelElem
    Dim Objecttype As String
   
    ' ---Filter
    Set oUserSel = aArray(j)
    Set oSelElem = oUserSel.ReferenceProduct.Parent
    Objecttype = TypeName(oSelElem)
   
    ' ---Filter anwenden für Parts
    If Objecttype = (uebObjTypeStr) Then
        Set FilterFunc = aArray(uebArrayCounterInt)
    End If

End Function

---

------------------
MFG Daniel

Systeminformation | Inoffizielle CATIA Hilfeseite | CATIA FAQ | Suche | TraceParts (Normteile...) | 3D Content Central (noch mehr Normteile...)

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

---

Hallo Daniel,

erstmal besten Dank für die Mühe. Die Verbesserung hat super funktioniert , ich musste allerdings
die Variablendeklaration noch ändern, weil mir nur CATvbs zur Verfügung steht.
Ich habe dann für die '***Kopieren und Einfügen Sektion noch eine Unterroutine erstellt (Müsste doch eigentlich Sinn machen).

Code:

---

Private aArray()
Private oSel
Private oProduct2

Sub CATMain()

' ---Selektierte Elemente
      Set oSel = CATIA.ActiveDocument.Selection
 
    If oSel.Count = 0 Then
        MsgBox ("Kein Dokument Selektiert")
        Exit Sub
    End If
   
    ' ---Produkt erzeugen
    Set oProduct1 = CATIA.Documents.Add("Product")
    Set oProduct2 = oProduct1.Product
       
    ' ---Selektion Auslesen
    ReDim Preserve aArray(oSel.Count - 1)
    For i = 1 To oSel.Count
        ' ---Wert dem Arrayfeld zuordnen
        Set aArray(i - 1) = oSel.Item(i).Value
    Next

    ' ---Selektion löschen
    oSel.Clear

    ' ---Arrayobjekte der Selektion hinzufügen
    For j = 0 To UBound(aArray)
        On Error Resume Next
        oSel.Add FilterFunc(j, "PartDocument")
        On Error GoTo 0
    Next

    ' ---Kopieren und Einfügen
    CopyPaste ("CATProdCont")

    oSel.Clear

    ' ---Arrayobjekte der Selektion hinzufügen
    For j = 0 To UBound(aArray)
        On Error Resume Next
        oSel.Add FilterFunc(j, "ProductDocument")
        On Error GoTo 0
    Next

    ' ---Kopieren und Einfügen
    CopyPaste ("CATSpecBreakLink")

    oSel.Clear

End Sub

Private Function FilterFunc(Zaehler, Objekttyp)

    Dim oUserSel
    Dim oSelElem
    Dim Objecttype
   
    ' ---Filter
    Set oUserSel = aArray(Zaehler)
    Set oSelElem = oUserSel.ReferenceProduct.Parent
    Objecttype = TypeName(oSelElem)
   
    ' ---Filter anwenden für Parts
    If Objecttype = (Objekttyp) Then
        Set FilterFunc = aArray(Zaehler)
    End If

End Function

Private Sub CopyPaste (Einfuegen)

If oSel.Count <> 0 Then
oSel.Copy
oSel.Clear
oSel.Add oProduct2
oSel.PasteSpecial (Einfuegen)
End If

---

Werde mich jetzt noch mit SelectElement beschäftigen, wenn beim Start des Makros noch nichts selektiert ist.
Besten Dank nochmal

Gruß
Sven

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