---

Hallo liebe Community,

ich versuche eine Powercopy in ein Part welches sich in einem Product befindet zu instanzieren.

Dafür gibt es bereits einen Beitrag:

http://forum.cad.de/foren/ubb/Forum137/HTML/004027.shtml

Ich habe mir die Datei die im Beitrag geteilt wurde, runtergeladen und auch schon angeschaut.

Nachdem ich den ersten Punkt ausgewäht habe, kommt an der Fett markierten Stelle eine Fehlermeldung.

Der Code sieht wie folgt aus:

Code:

---

Sub CATMain()
    '****Deklarationen
    Const intSourcePartPathStr = "C:\Users\UserA\Desktop\Kopie_von_InsertPCinProd\110-0001_00_EZ_MITTELLINIE_PC.CATPart"
    Dim intDocObj As Document
    Dim intWindowsObj As Windows
    Dim intObjTypeStr As String
    Dim intSelObj As Object 'Selection
    Dim intSelFilterColl As New Collection
    Dim intSelFilter(0)
    Dim intSelStateStr As String
    Dim intPointColl As New Collection
    Dim intTargetPartObj As Part
    Dim intInstFacObj As InstanceFactory
    Dim intRootDocObj As Object
 
    '***Abfrage des Quellpfades
    If CATIA.FileSystem.FileExists(intSourcePartPathStr) = False Then
        MsgBox "Das Quellbauteil (Bauteil mit PowerCopy-Feature) wurde nicht gefunden" + vbNewLine + _
                "Bitte Ändern Sie den Quelltext und starten Sie das Makro erneut!", vbExclamation, "Kein Quellbauteil gefunden"
        Exit Sub
    End If
 
    '****Abfrage Dokumente
    Set intWindowsObj = CATIA.Windows
    If intWindowsObj.Count = 0 Then
        MsgBox "Es ist kein Dokument geladen!" + Chr(10) + "Das Makro kann nicht ausgeführt werden und wird beendet!", vbCritical, "Keine Dokument geladen"
        Exit Sub
    End If
    Set intDocObj = CATIA.ActiveDocument
    intObjTypeStr = TypeName(intDocObj)
    'If intObjTypeStr <> "DrawingDocument" Then
        'MsgBox "Das aktive Dokument ist kein DrawingDocument!" + Chr(10) + "Das Makro kann nicht ausgeführt werden!", _
                'vbCritical + vbOKOnly, "Falscher Dokumententyp"
        'Exit Sub
    'End If
    intObjTypeStr = ""
     
    '****Selektion der Inputgeometrie (2 Punkte)
    Set intRootDocObj = CATIA.ActiveDocument
    Set intSelObj = intRootDocObj.Selection
    intSelObj.Clear
 
    '***Startpunkt selektieren
    MsgBox "Bitte selektieren Sie den Startpunkt" + vbNewLine + "ESC zum Abbrechen der Selektion und des Makros", vbInformation, "Startpunkt selektieren"
    intSelFilterColl.Add "Point"
    intPointColl.Add PointSelectionFunc(intSelObj, "Bitte Startpunkt selektieren", intSelFilterColl)
 
    If intPointColl.Count = 0 Then
        Exit Sub
    Else
        intSelObj.Clear
    End If
     
    '***Endpunkt selektieren
    MsgBox "Bitte selektieren Sie den Endpunkt" + vbNewLine + "ESC zum Abbrechen der Selektion und des Makros", vbInformation, "Endpunkt selektieren"
    intPointColl.Add PointSelectionFunc(intSelObj, "Bitte Endpunkt selektieren", intSelFilterColl)
     
    If intPointColl.Count = 1 Then
        Exit Sub
    Else
        intSelObj.Clear
    End If
 
    '***PowerCopy einfügen
    MsgBox "Bitte selektieren Sie das Part in dem Sie das PowerCopy einfügen möchten" + vbNewLine + _
            "ESC zum Abbrechen der Selektion und des Makros", vbInformation, "Zielpart"
         
    Set intTargetPartObj = PointSelectionFunc(intSelObj, "Bitte Endpunkt selektieren", intSelFilterColl)
     
    If intTargetPartObj Is Nothing Then
        Exit Sub
    Else
        intSelObj.Clear
    End If
 
    Set intInstFacObj = intTargetPartObj.GetCustomerFactory("InstanceFactory")
    intInstFacObj.BeginInstanceFactory "PowerCopy.MITTELLINIE", intSourcePartPathStr
    intInstFacObj.BeginInstantiate
    '***Startpunkt übergeben
    intInstFacObj.PutInputData "INPUT_STARTPOINT", intPointColl.Item(1)
    '***Endpunkt übergeben
    intInstFacObj.PutInputData "INPUT_ENDPUNKT", intPointColl.Item(2)
 
    intInstFacObj.EndInstantiate
    intInstFacObj.EndInstanceFactory
    myPart.Update
     
 
End Sub

Private Function PointSelectionFunc(ByVal uebSelObj As Object, ByVal uebMsgStr As String, ByVal uebSelFilter As Collection) As Object
    '***Deklarationen
    Dim intSelStateStr As String
    Dim intSelFilter()
    Dim i As Integer
 
    '***Filter umwandeln (Collection to Array)
    ReDim intSelFilter(uebSelFilter.Count - 1)
    For i = 1 To uebSelFilter.Count
        intSelFilter(i - 1) = uebSelFilter.Item(i)
    Next
 
    '***Seletion ausführen
    intSelStateStr = uebSelObj.SelectElement2(intSelFilter, uebMsgStr & " / ESC zum Abbrechen", False)
    If intSelStateStr = "Normal" Then
        Set PointSelectionFunc = intSelObj.Item(1).Value <======= HIER
        Exit Function
    Else
        MsgBox "Die Selektion war NICHT erfolgreich" + vbNewLine + _
                "Das Makro wird beendet", vbExclamation, "Selektion nicht erfolgreich"
        Set PointSelectionFunc = Nothing
        Exit Function
    End If
End Function

---

Ich habe viel rumprobiert, leider ohne Erfolg.

Für eure Tips wäre ich sehr dankbar.

Viele Grüße 

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

---

Servus
Wie lautet die Fehlermeldung?
Müsste es in der Zeile nicht uebSelObj satt intSelObj heißen?

Gruß
BErnd

------------------
Warum einfach, wenn es auch kompliziert geht.

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

---

Fehlertyp.JPG

Hallo Bernd,

herzlichen Dank da war der Haken.

Jedoch hänge ich wieder an einer anderen Stelle (unten Fett und Kursiv), Screenshot des Fehlers habe ich hochgeladen:

Code:

---

Sub CATMain()
    '****Deklarationen
    Const intSourcePartPathStr = "C:\Users\UserA\Desktop\Kopie_von_InsertPCinProd\110-0001_00_EZ_MITTELLINIE_PC.CATPart"
    Dim intDocObj As Document
    Dim intWindowsObj As Windows
    Dim intObjTypeStr As String
    Dim intSelObj As Object 'Selection
    Dim intSelFilterColl As New Collection
    Dim intSelFilter(0)
    Dim intSelStateStr As String
    Dim intPointColl As New Collection
    Dim intTargetPartObj As Part
    Dim intInstFacObj As InstanceFactory
    Dim intRootDocObj As Object
 
    '***Abfrage des Quellpfades
    If CATIA.FileSystem.FileExists(intSourcePartPathStr) = False Then
        MsgBox "Das Quellbauteil (Bauteil mit PowerCopy-Feature) wurde nicht gefunden" + vbNewLine + _
                "Bitte Ändern Sie den Quelltext und starten Sie das Makro erneut!", vbExclamation, "Kein Quellbauteil gefunden"
        Exit Sub
    End If
 
    '****Abfrage Dokumente
    Set intWindowsObj = CATIA.Windows
    If intWindowsObj.Count = 0 Then
        MsgBox "Es ist kein Dokument geladen!" + Chr(10) + "Das Makro kann nicht ausgeführt werden und wird beendet!", vbCritical, "Keine Dokument geladen"
        Exit Sub
    End If
    Set intDocObj = CATIA.ActiveDocument
    intObjTypeStr = TypeName(intDocObj)
    'If intObjTypeStr <> "DrawingDocument" Then
        'MsgBox "Das aktive Dokument ist kein DrawingDocument!" + Chr(10) + "Das Makro kann nicht ausgeführt werden!", _
                'vbCritical + vbOKOnly, "Falscher Dokumententyp"
        'Exit Sub
    'End If
    intObjTypeStr = ""
     
    '****Selektion der Inputgeometrie (2 Punkte)
    Set intRootDocObj = CATIA.ActiveDocument
    Set intSelObj = intRootDocObj.Selection
    intSelObj.Clear
 
    '***Startpunkt selektieren
    MsgBox "Bitte selektieren Sie den Startpunkt" + vbNewLine + "ESC zum Abbrechen der Selektion und des Makros", vbInformation, "Startpunkt selektieren"
    intSelFilterColl.Add "Point"
    intPointColl.Add PointSelectionFunc(intSelObj, "Bitte Startpunkt selektieren", intSelFilterColl)
 
    'If intPointColl.Count = 0 Then
        'Exit Sub
    'Else
        'intSelObj.Clear
    'End If
     
    '***Endpunkt selektieren
    MsgBox "Bitte selektieren Sie den Endpunkt" + vbNewLine + "ESC zum Abbrechen der Selektion und des Makros", vbInformation, "Endpunkt selektieren"
    intSelFilterColl.Add "Point"
    intPointColl.Add PointSelectionFunc(intSelObj, "Bitte Endpunkt selektieren", intSelFilterColl)
     
    'If intPointColl.Count = 1 Then
        'Exit Sub
    'Else
        'intSelObj.Clear
    'End If
 
    '***PowerCopy einfügen
    MsgBox "Bitte selektieren Sie das Part in dem Sie das PowerCopy einfügen möchten" + vbNewLine + _
            "ESC zum Abbrechen der Selektion und des Makros", vbInformation, "Zielpart"
    intSelFilterColl.Add "Part"
         
    Set intTargetPartObj = PointSelectionFunc(intSelObj, "Bitte Endpunkt selektieren", intSelFilterColl)
     
    If intTargetPartObj Is Nothing Then
        Exit Sub
    Else
        intSelObj.Clear
    End If
 
    Set intInstFacObj = intTargetPartObj.GetCustomerFactory("InstanceFactory")
    intInstFacObj.BeginInstanceFactory "PowerCopy.MITTELLINIE", intSourcePartPathStr <==========HIER
    intInstFacObj.BeginInstantiate
    '***Startpunkt übergeben
    intInstFacObj.PutInputData "INPUT_STARTPOINT", intPointColl.Item(1)
    '***Endpunkt übergeben
    intInstFacObj.PutInputData "INPUT_ENDPUNKT", intPointColl.Item(2)
 
    intInstFacObj.EndInstantiate
    intInstFacObj.EndInstanceFactory
    myPart.Update
     
 
End Sub

Private Function PointSelectionFunc(ByVal uebSelObj As Object, ByVal uebMsgStr As String, ByVal uebSelFilter As Collection) As Object
    '***Deklarationen
    Dim intSelStateStr As String
    Dim intSelFilter()
    Dim i As Integer
 
    '***Filter umwandeln (Collection to Array)
    ReDim intSelFilter(uebSelFilter.Count - 1)
    For i = 1 To uebSelFilter.Count
        intSelFilter(i - 1) = uebSelFilter.Item(i)
    Next
 
    '***Seletion ausführen
    intSelStateStr = uebSelObj.SelectElement2(intSelFilter, uebMsgStr & " / ESC zum Abbrechen", False)
    If intSelStateStr = "Normal" Then
        Set PointSelectionFunc = uebSelObj.Item(1).Value
        Exit Function
    Else
        MsgBox "Die Selektion war NICHT erfolgreich" + vbNewLine + _
                "Das Makro wird beendet", vbExclamation, "Selektion nicht erfolgreich"
        Set PointSelectionFunc = Nothing
        Exit Function
    End If
End Function

---

KT1 Lizenz ist vorhanden. PowerCopy Name und Speicherort stimmen.

Danke für deine Hilfe

Grüße 

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

---

Servus
Ist die richtige Workbench aktiv? (PartDesign)
Starte den Code mal in einem Part.

Gruß
Bernd

------------------
Warum einfach, wenn es auch kompliziert geht.

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

---

Hallo Bernd,

habe es versucht, leider der selbe Fehler.

Grüße 

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

---

Servus
Ich kann keinen Fehler erkennen.
Bitte nochmal prüfen:
- KT1-Lizenz vorhanden
- stimmen Pfad und Name der PowerCopy
- hast du das Part mit der PowerCopy in einem anderen Fenster geöffnet?
- funktioniert die PowerCopy manuell?
(benutzt du die Dateien aus der andern Diskussion? Welche dann, die von Daniel?)

Gruß
Bernd

------------------
Warum einfach, wenn es auch kompliziert geht.

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

---

Hallo Bernd,

herzlichen Dank, du hast wieder recht.

Beim manuellen Einfügen der Powercopy kommt eine Fehlermeldung.

Ich habe es an einem eigenen Beispiel ausprobiert, das Makro läuft durch, es passiert leider nichts. Habe auch ein Debugging durchgeführt, es läuft komplett durch.
Ich kann es mir leider nicht erklären  .

Grüße 

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

---

Servus
Wie sieht dein eigenes Beispiel aus (Screenshot mit dem Namen und den Inputs)?
Wie sieht da dein Code aus (Bereich mit den InstanceFactory und den Inputs)?

Gruß
Bernd

------------------
Warum einfach, wenn es auch kompliziert geht.

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

---

Hallo Bernd,

ich habe es anderweitig lösen können. Hier der Code, vielleicht braucht es jemand irgendwann:

Code:

---

Sub CATMain()

Dim productDocument1 As ProductDocument
Set productDocument1 = CATIA.ActiveDocument

Dim product1 As Product
Set product1 = productDocument1.Product

Dim products1 As Products
Set products1 = product1.Products

Dim documents1 As Documents
Set documents1 = CATIA.Documents

Dim partDocument1 As PartDocument
Set partDocument1 = documents1.Item("Partname.CATPart")

Dim part1 As Part
Set part1 = partDocument1.Part

Dim myFactory As InstanceFactory
Set myFactory = part1.GetCustomerFactory("InstanceFactory")

myFactory.BeginInstanceFactory "PowercopyName", "PowercopyOrt"

myFactory.BeginInstantiate

'Auswahl festlegen -----------------------------------------------
Dim Filter(1)
Filter(0) = "Point"
Filter(1) = "Plane"

'Selektion definieren und leeren ---------------------------------
Dim UserSel As Object
Set UserSel = CATIA.ActiveDocument.Selection
UserSel.Clear

'Selection vornehmen lassen --------------------------------------
Dim intSelAbfrageStr As String
Dim intPointObj, intPlaneObj As Object

intSelAbfrageStr = UserSel.SelectElement2(Filter, "Bezugspunkt waehlen", False)

If intSelAbfrageStr = "Normal" Then
  Set intPointObj = UserSel.Item(1).Value
End If

'Selektierte Geometrie an die PowerCopy senden --------------------
myFactory.PutInputData "Mittelpunkt", intPointObj 

UserSel.Clear

intSelAbfrageStr = UserSel.SelectElement2(Filter, "Bezugsebene waehlen", False)

If intSelAbfrageStr = "Normal" Then
  Set intPlaneObj = UserSel.Item(1).Value
End If

'Selektierte Geometrie an die PowerCopy senden --------------------
myFactory.PutInputData "Ebene_kontur", intPlaneObj

UserSel.Clear

Dim Instance As ShapeInstance
Set Instance = myFactory.Instantiate
'-----------------------------------------------------------------
myFactory.EndInstantiate
'------------------------------------------------------------------
myFactory.EndInstanceFactory
'------------------------------------------------------------------
part1.Update

End Sub

---

Vielen Dank für deine Zeit

Herzliche Grüße 

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

---

Servus
Verbesserungsvorschlag:
Dein Filter Punkt/Ebene gilt für beide Selektionen. Bei der ersten sollte sicher nur ein Punkt selektiert werden können. Also Filter je nach Fall einschränken.

Gruß
Bernd

------------------
Warum einfach, wenn es auch kompliziert geht.

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

---

Hallo Bernd,

danke für den Tip  , werde ich anpassen.

Herzliche Grüße 

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

---

Servus
Weiterer Tipp: was soll passieren wenn die Selektion (ESC) abgebrochen wird?
Im Moment läuft das Makro einfach weiter, und fliegt dir um die Ohren.

Gruß
Bernd

------------------
Warum einfach, wenn es auch kompliziert geht.

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