---

Gruß an Allem

Ich möchte kleine Makro bauen, welcher wird mir zeigen welche Unterprodukte und Parts in Auto-Null nicht aufgebaut sind. Parts mussen spezifische Namen haben, z.B. "......AUFLAGE.....CATPart" - alle andere Teile mussen ignoriert sein.

Ich kann separat ein Selektion markieren für Produkte und spezifische Teile aber ich weiß nicht wie kann ich alle Objekte im ein Selektion haben, wenn sie unterschiedliche Objekte sind   weiter, das Makro soll prüfen, ob das Objekt hat Lokal Achsenkreuz im Auto-Null. Wenn nein - dann Makro soll mir auslisten im Fenster welsche Komponenten haben nicht. Sorry für mein schlecht Deutsch. Ich hoffe dass ich habe das gut erklärt  

[Diese Nachricht wurde von Sylas am 19. Sep. 2013 editiert.]

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

---

Hallo Sylas,

wie sieht dein Code bisher aus?

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

---

Zitat:

---

Original erstellt von imation1999:
Hallo Sylas,

wie sieht dein Code bisher aus?

---

Gibt es nichts zu zeigen ;) ich bin nur am Anfang.

Code:

---

Sub CATMain()

For Each oDoc In CATIA.Documents

Dim Sel1
Dim Sel2
Dim oDoc
Set oDoc = CATIA.ActiveDocument

'Alle Produkte und sollte genommen sein...
Set Sel1 = CATIA.ActiveDocument.Selection
Sel1.Search "((CATProductSearch.Assembly + CATAsmSearch.Assembly) + CATPcsSearch.Assembly),all"

If TypeName(oDoc) = "ProductDocument" Then
Set Sel1 = CATIA.ActiveDocument.Selection
Dim oProdDoc
Set oProdDoc = oDoc
Sel1.add oProdDoc

'...und jedes Part, welsches z.B. "ADAPTER" Zwischenname hat:

ElseIf TypeName(oDoc) = "PartDocument" Then
Dim oPartDoc
Set Sel2 = CATIA.ActiveDocument.Selection
Set oPartDoc = oDoc
If InStr(oPartDoc.Name,"ADAPTER") > 0 then
Sel2.add oPartDoc
ElseIf InStr(oPartDoc.Name,"DRUCKSTUECK") > 0 then
Sel2.add oPartDoc
ElseIf InStr(oPartDoc.Name,"AUFLAGE") > 0 then
Sel2.add oPartDoc
ElseIf InStr(oPartDoc.Name,"KONTURSTUECK") > 0 then
Sel2.add oPartDoc
ElseIf InStr(oPartDoc.Name,"KONTURSTÜCK") > 0 then
Sel2.add oPartDoc
ElseIf InStr(oPartDoc.Name,"DRUCKSTÜCK") > 0 then
Sel2.add oPartDoc

'dann nur eine Kollektion soll sein:

' Sel_alle = Sel1+Sel2

'fuer jedes Element von Sel_alle Makro muss Local Achsenkreuz pruefen, ob in Auto-null ist:

'for i=1 to Sel_alle.count
'Sel_alle.item(i).getcomponents
'if Sel_alle.item(i).getcomponents <>[{0,0,0},{0,0,0},{0,0,0}] then
'dim sel_bad
' sel_bad.add Sel_alle.item(i)
'else
'end if

'Liste fuer sel.bad anzeigen:

'Call ListingNames(Sel_bad)

Next
End Sub

---

Das Problem ist, dass ActiveDocument.Selection macht mir neues selektion - aber die altes ist verloren  . Ich kann nicht weiter gehen - sorry...

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

---

Servus
Wozu willst du gesamte Docments-Collection abarbeiten?
Meinen Verständnis nach willst du die Position von CATParts (mit bestimmten Namen) überprüfen.
Dann sollte das Makro auch von der aus Rootbaugruppe starten.

Code:

---

Sub CATMain()

Dim ProdDoc As ProductDocument
Dim osel As Selection
Dim objSel As Object
Dim i As Integer
Dim PartProduct 'As Product

'Dokument geöffnet
If CATIA.Windows.Count = 0 Then
    Exit Sub
End If

'CATProduct geöffnet
If TypeName(CATIA.ActiveDocument) <> "ProductDocument" Then
    MsgBox "Keine CATProduct geöffnet"
    Exit Sub
End If

'Start
Set ProdDoc = CATIA.ActiveDocument
Set objSel = ProdDoc.Selection
Set osel = objSel

'Suche
osel.Clear
osel.Search "(CATAsmSearch.Part.PartNumber=*ADAPTER* + CATAsmSearch.Part.Name=*DRUCK*),all"

'Vergleichsarray erstellen
Dim NullPosArray()
NullPosArray = Array(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0)
Dim PosArray(11)

'Position auslesen und vergleichen
For i = 1 To osel.Count2
      Set PartProduct = osel.Item2(i).Value
      'PartProduct.Position.GetComponents PosArray
      PartProduct.Position.GetComponents (PosArray)
      If Not (CompareArrays(PosArray, NullPosArray)) Then
        'mach was
      End If
Next

End Sub

Function CompareArrays(ByRef arr1(), ByRef arr2()) As Boolean
    Dim i As Integer
    For i = 0 To UBound(arr1) 'hier eben dieses erste element auslassen deshalb auch von 1
        If arr1(i) <> arr2(i) Then
            CompareArrays = False
            Exit Function
        End If
    Next
    CompareArrays = True
End Function

---

Gruß
Bernd

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

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

---

Zitat:

---

Original erstellt von bgrittmann:
Servus
Wozu willst du gesamte Docments-Collection abarbeiten?
Meinen Verständnis nach willst du die Position von CATParts (mit bestimmten Namen) überprüfen.
Dann sollte das Makro auch von der aus Rootbaugruppe starten.

Code:

---

Sub CATMain()

Dim ProdDoc As ProductDocument
Dim osel As Selection
Dim objSel As Object
Dim i As Integer
Dim PartProduct 'As Product

'Dokument geöffnet
If CATIA.Windows.Count = 0 Then
    Exit Sub
End If

'CATProduct geöffnet
If TypeName(CATIA.ActiveDocument) <> "ProductDocument" Then
    MsgBox "Keine CATProduct geöffnet"
    Exit Sub
End If

'Start
Set ProdDoc = CATIA.ActiveDocument
Set objSel = ProdDoc.Selection
Set osel = objSel

'Suche
osel.Clear
osel.Search "(CATAsmSearch.Part.PartNumber=*ADAPTER* + CATAsmSearch.Part.Name=*DRUCK*),all"

'Vergleichsarray erstellen
Dim NullPosArray()
NullPosArray = Array(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0)
Dim PosArray(11)

'Position auslesen und vergleichen
For i = 1 To osel.Count2
      Set PartProduct = osel.Item2(i).Value
      'PartProduct.Position.GetComponents PosArray
      PartProduct.Position.GetComponents (PosArray)
      If Not (CompareArrays(PosArray, NullPosArray)) Then
        'mach was
      End If
Next

End Sub

Function CompareArrays(ByRef arr1(), ByRef arr2()) As Boolean
    Dim i As Integer
    For i = 0 To UBound(arr1) 'hier eben dieses erste element auslassen deshalb auch von 1
        If arr1(i) <> arr2(i) Then
            CompareArrays = False
            Exit Function
        End If
    Next
    CompareArrays = True
End Function

---

Gruß
Bernd

---

Servus Bernd
Lang nicht gehört :)

Ich möchte auch Position des Produktes prüfen - aber so viel ich weiß - es gibt keine Achsenkreuz für Zusammenbau - richtig? Stadt dass, ich kann der Position für erstes Part in Produkt prüfen - ist das Wahr? Noch kleine Frage? Wie macht Mann ein VBA Fehnster mit Partliste mit dieses Wahrung:

Code:

---

If Not (CompareArrays(PosArray, NullPosArray)) Then
        'mach was

---

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

---

Servus
Steng genommen müsstest du von allen Products (Unterbargruppen, Bauteilen und Components die Position überprüfen. Zusätzlich müsstest du je nachdem die Anforderngen sind) auch in den CATParts auch die Achsensysteme prüfen. Also liegt das Besugsachsensystem noch bei Null (zum PartUrsprung) was ist das Bezugachsensstem? ...
Du könntest zB eine Listbox mit der PartNumber, Dateinamen, ... füllen. Oder ist eine Textdatei schreiben, .....

Gruß
Bernd

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

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

---

Zitat:

---

Original erstellt von bgrittmann:
Servus
Steng genommen müsstest du von allen Products (Unterbargruppen, Bauteilen und Components die Position überprüfen. Zusätzlich müsstest du je nachdem die Anforderngen sind) auch in den CATParts auch die Achsensysteme prüfen. Also liegt das Besugsachsensystem noch bei Null (zum PartUrsprung) was ist das Bezugachsensstem? ...
Du könntest zB eine Listbox mit der PartNumber, Dateinamen, ... füllen. Oder ist eine Textdatei schreiben, .....

Gruß
Bernd

---

Code:

---

NullPosArray = Array(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0)

---

gibt mier Type Mismatch Fehler - soll ich Fehlerfenster einfügen?

Ich bin nicht sicher, ob habe ich dir richtig verstanden (ich spreche Deutsch immer noch nicht Gut).

Was ich will ist: Prüfen, ob alle Unterbaugruppen und Teile mit spezifische Namen (die welche z.B. Kontakt mit Karosserie
haben) in Auto-Null liegen (aufgebaut sind). Das heißt, dass Achsensystem von Part muß in Auto-Null (Globalachsensystem) liegen (0,0,0). Wenn liegen nicht, dann ich soll ein Fehnster kriegen, mit Partliste wo alle Teile, welche diese Bedingung nicht erfüllen, ausgelistet sind.

[Diese Nachricht wurde von Sylas am 20. Sep. 2013 editiert.]

[Diese Nachricht wurde von Sylas am 20. Sep. 2013 editiert.]

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

---

Servus
Wenn du auch Prodcts und Components überprüfen willst muss du in meinem Makro die Suche entsprechend anpassen.
Oder mit einem rekursiven Makro den Baum abarbeiten -> Name prüfen -> Position prüfen.

Das Makro läuft bei mir in VBA ohne Fehler durch. Versuch mal alternativ den Array über eine Schleife zu füllen:

Code:

---

For i = 0 To UBound(NullPosArray)
    NullPosArray(i) = 0
Next

---

Gruß
Bernd

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

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

---

Zitat:

---

Original erstellt von bgrittmann:
Servus
Wenn du auch Prodcts und Components überprüfen willst muss du in meinem Makro die Suche entsprechend anpassen.
Oder mit einem rekursiven Makro den Baum abarbeiten -> Name prüfen -> Position prüfen.

Das Makro läuft bei mir in VBA ohne Fehler durch. Versuch mal alternativ den Array über eine Schleife zu füllen:

Code:

---

For i = 0 To UBound(NullPosArray)
    NullPosArray(i) = 0
Next

---

Gruß
Bernd

---

Schönen dank Bernd für deine Erklärung!

Noch ein kleine einfache Sache: wie kann ich einfach die Teile welche die Bedinung:

Code:

---

If Not (CompareArrays(PosArray, NullPosArray)) Then

---

erfüllen nicht, auflisten im Fenster oder selektiren? Ich habe sowas probiert:

Code:

---

Set objSel2 = ProdDoc.Selection
Set osel2 = objSel2
osel2.add PartProduct
      End If
Next

MsgBox osel2

---

aber das funktioniert nicht 

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

---

Servus
Es gibt nur eine Selektion im Dokument.
Also musst du dir was anderes einfallen lassen um die Teile/Werte/ zwischenzuspeichern kannst:
- ein Collection füllen
- die Selektion von hinten durcharbeiten, alles Teile die bei "Null" liegen aus der Selektion entfernen
- ein Listbox füllen
- ....

Gruß
Bernd

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

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

---

Hallo Bernd,

vielen Dank für diese super Makro.
...soll aber das NullPosArray nicht so aussehen?

Code:

---

NullPosArray = Array(1, 0, 0, 0, 1, 0, 0, 0, 1, 0, 0, 0)

---

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

---

Servus
Ups, du hast recht die Einheitsvektoren für die Richtungen müssen gesetzt sein. 10 Us sind unterwegs.

Gruß
Bernd

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

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

---

Zitat:

---

Original erstellt von imation1999:
Hallo Bernd,

vielen Dank für diese super Makro.
...soll aber das NullPosArray nicht so aussehen?

Code:

---

NullPosArray = Array(1, 0, 0, 0, 1, 0, 0, 0, 1, 0, 0, 0)

---

---

Danke für deinen Tip imation1999.

Jungs - ich bin so nähe zum Ende - kann irgendwer mir Rest zeigen?

Wie kann ich aus oSel Elemente löschen (wenn PosArray nicht genau NullPosArray ist) und Rest im Fenster shauen?

Kann Mann nur Origins von dem Achsenkreuze vergleichen?

Ich lerne noch - ich kann nicht das selber machen. Danke im Voraus.

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

---

Servus
So könnte man die nicht passenden Teile aus der Selektion entfernen:

Code:

---

For i = osel.Count2 to 1 Step -1
      Set PartProduct = osel.Item2(i).Value
      'PartProduct.Position.GetComponents PosArray
      PartProduct.Position.GetComponents (PosArray)
      If CompareArrays(PosArray, NullPosArray) Then
        osel.remove2(i)
      End If
Next

---

Wie du das in zB eine Listbox bekommst: siehe Hilfe im VBA-Editor.
Schau mal in die Doku was dir "GetComponents" zurück liefert, dann ist deine weitere Frage beantwortet.

Gruß
Bernd

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

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

---

Zitat:

---

Original erstellt von bgrittmann:
Servus
So könnte man die nicht passenden Teile aus der Selektion entfernen:

Code:

---

For i = osel.Count2 to 1 Step -1
      Set PartProduct = osel.Item2(i).Value
      'PartProduct.Position.GetComponents PosArray
      PartProduct.Position.GetComponents (PosArray)
      If CompareArrays(PosArray, NullPosArray) Then
        osel.remove2(i)
      End If
Next

---

Wie du das in zB eine Listbox bekommst: siehe Hilfe im VBA-Editor.
Schau mal in die Doku was dir "GetComponents" zurück liefert, dann ist deine weitere Frage beantwortet.

Gruß
Bernd

---

Ich habe Mal einfach das Code ausgetauscht, und mit einfache:

Code:

---

Msgbox oSel.count

---

geprüft, wie viel Elemente sind in oSel vor und nach der Makro - ich kriege das gleiche Wert - das heißt dass das Code hat mir nichts aus Selektion gelöcht (Ich bin sicher, dass mindesten zwei Teile sind nicht im Null). Was habe ich Falsch gemacht?

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

---

Servus
Benutze bitte das Watchfenster und Break-Poinst im VBA-Editor um zu  suchen warum nicht aus de Selektion entfernt wird.
Wird die Zeile überhaupt aufgerufen? Passen die Werte im NullPosArray? Wie sehen im Vergleich die PosArrays aus? ...

Gruß
Bernd

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

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

---

Zitat:

---

Original erstellt von bgrittmann:
Servus
Benutze bitte das Watchfenster und Break-Poinst im VBA-Editor um zu  suchen warum nicht aus de Selektion entfernt wird.
Wird die Zeile überhaupt aufgerufen? Passen die Werte im NullPosArray? Wie sehen im Vergleich die PosArrays aus? ...

Gruß
Bernd

---

Servus

Sorry Bernd, aber ich kann nur Skripte schreiben - ich kann nicht VBA unter Catia starten.
Ich immer baue deinen Code um für scripting.

Wie kann ich "manuel" Arrays vergleichen? Ich kann dir nur die Werte direkt aus CATIA zeigen, z.B.:

NullPosArray habe ich nach imation1999 Hinweis definiert:

Code:

---

Sub CATMain()
Dim ProdDoc As ProductDocument
Dim osel As Selection
Dim objSel As Object
Dim i As Integer
Dim PartProduct 'As Product

'Dokument geöffnet
If CATIA.Windows.Count = 0 Then
    Exit Sub
End If

'CATProduct geöffnet
If TypeName(CATIA.ActiveDocument) <> "ProductDocument" Then
    MsgBox "Keine CATProduct geöffnet"
    Exit Sub
End If

'Start
Set ProdDoc = CATIA.ActiveDocument
Set objSel = ProdDoc.Selection
Set osel = objSel

'Suche
osel.Clear
osel.Search "(CATAsmSearch.Part.Name=*ADAPTER* + CATAsmSearch.Part.Name=*DRUCK* + CATAsmSearch.Part.Name=*KONTUR* + CATAsmSearch.Part.Name=*AUFLAGE*),all"

'Vergleichsarray erstellen
Dim NullPosArray
NullPosArray = Array(1, 0, 0, 0, 1, 0, 0, 0, 1, 0, 0, 0)
Dim PosArray(11)

MsgBox osel.count

'Position auslesen und vergleichen
For i = osel.Count2 to 1 Step -1
      Set PartProduct = osel.Item2(i).Value
      'PartProduct.Position.GetComponents PosArray
      PartProduct.Position.GetComponents (PosArray)
      If CompareArrays(PosArray, NullPosArray) Then
        osel.remove2(i)
      End If
Next

MsgBox osel.count

End Sub

Function CompareArrays(ByRef arr1(), ByRef arr2()) As Boolean
    Dim i As Integer
    For i = 0 To UBound(arr1) 'hier eben dieses erste element auslassen deshalb auch von 1
        If arr1(i) <> arr2(i) Then
            CompareArrays = False
            Exit Function
        End If
    Next
    CompareArrays = True
End Function

---

[Diese Nachricht wurde von Sylas am 20. Sep. 2013 editiert.]

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

---

Hallo,

ich würde einfach so machen:

Code:

---

'Position auslesen und vergleichen
For i = osel.Count2 to 1 Step -1
      Set PartProduct = osel.Item2(i).Value
      'PartProduct.Position.GetComponents PosArray
      PartProduct.Position.GetComponents (PosArray)
      If not CompareArrays(PosArray, NullPosArray) Then
MsgList = osel.Item(i).Value.Name & Chr(10) & MsgList       
End If
Next

MsgBox MsgList

End Sub

---

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

---

Hallo

Danke Kollegen für ihre Ideen.

Ich denke noch, wie kann ich dem Makro noch verbessern - ergänzen... Ich möchte noch ein MsgBox schreiben, mit Text:

Code:

---

"Kein Part welsches aus AutoNull liegt!"

---

,

wenn

Code:

---

'Position auslesen und vergleichen
For i = osel.Count2 to 1 Step -1
      Set PartProduct = osel.Item2(i).Value
      'PartProduct.Position.GetComponents PosArray
      PartProduct.Position.GetComponents (PosArray)
      If not CompareArrays(PosArray, NullPosArray) Then
MsgList = osel.Item(i).Value.Name & Chr(10) & MsgList
 
End If
Next
MsgBox MsgList

End Sub

---

gibt mir Null und Ich will ein TXT-Datei haben mit

Code:

---

osel

---

aufgelistet. Ist dass machtbar?

[Diese Nachricht wurde von Sylas am 30. Sep. 2013 editiert.]

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

---

Servus
Daten in ein txt-Datei schreiben, siehe zB hier.
Du könntest vor dem Anzeigen der MsgBox die Länge des des Strings (len) "MsgList" prüfen, und falls diese 0 ist dein alternativen Text in die Variable schreiben.

Gruß
Bernd

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

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

---

Zitat:

---

Original erstellt von bgrittmann:
Servus
Daten in ein txt-Datei schreiben, siehe zB hier.
Du könntest vor dem Anzeigen der MsgBox die Länge des des Strings (len) "MsgList" prüfen, und falls diese 0 ist dein alternativen Text in die Variable schreiben.

Gruß
Bernd

---

also z.B. so?

Code:

---

'Position auslesen und vergleichen
For i = osel.Count2 to 1 Step -1
      Set PartProduct = osel.Item2(i).Value
      'PartProduct.Position.GetComponents PosArray
      PartProduct.Position.GetComponents (PosArray)
      If not CompareArrays(PosArray, NullPosArray) Then
MsgList = osel.Item(i).Value.Name & Chr(10) & MsgList
   
End If
Next
if len(MsgList)=0 then
MsgList = "Kein Teil welsches aud AutoNull liegt!"
end if

MsgBox MsgList

End Sub

---

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