---

Hallo!

Ich hätte eine Frage bezüglich IDW und farblicher Unterscheidung zwischen Neuteile, vorhandene Teile und Demontage Teile.

Ich schreib einfach mal meine Vorgehensweise:

Derzeit habe ich eine Baugruppe mit mehreren Unterbaugruppen. Davon sind einige vorhandene Bauteile/Baugruppe (Umfeld) und neue Bauteile/Baugruppe. Ich erstelle Eine Ansicht in einer IDW. Nun wähle ich die Neuteile im Browser aus, klicke RMT und weise über Eigenschaften den Bauteilen/Baugruppen eine neue Layerfarbe, um diese vom Umfeld optisch abzusetzen.

Mein Problem ist das die Farben bei neuen Ansichten und Schnitte die aus der oben genannten Grundansicht erstellt werden nicht übernommen werden. Ich muss diese immer wieder neu in den jeweiligen Schnitten und Ansichten anwählen.

Kann ich den Bauteilen grundlegend eine Layerfarbe oder Layer zuweisen, den ich in der IDW nach belieben farblich ändern kann?

Die Anbauteile als Referenz anzuwählen so dass in der IDW jene den Phantomlayer zugeordnet bekommen finde ich nicht so handlich. Irgendwie hab ich immer Probleme mit den Phantombauteilen in Bezug auf Darstellung, verdeckte Linien usw. Zudem möchte ich versch. Neuteile versch. Farben zuordnen... aber eben nicht in jeder weiteren Ansicht oder Schnitt.

Kann mir jemand einen erleichternden Tipp geben?

greetz

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

---

Hallo,
Wir haben bei uns ähnliche Umstände (Müssen lt. Kundenwunsch verschiedene Maschinen- und Rohrleitungsteile auf unterschiedliche Layer legen - Übergabeformat ACAD-DWG). Bei uns wird das Ganze genau so wie du es beschrieben hast gehandhabt. Also händisch den Bauteilen/Baugruppen neuen Layer oder Farben zuweisen...

Blöd dabei:
Wird das dargestellte Modell so verändert das Teile von Baugruppen sichtbar sind die vorher nicht sichbar waren - und diese eigendlich händschisch auf eine neue Farbe gelegt wurden - dann liegen diese Bauteile wiederum auf dem Standardlayer. D.H. bei einer Modelländerung muss man immer wieder händisch nachbessern... 

Zumindest bis IV2009 ist mir keine Möglichkeit bekannt das mit Bordmitteln automatisch ablaufen zu lassen. 

Mit VB wäre da natürlich einiges möglich. Ein Gedankengang von mir wäre z.B. dass man in den Baugruppen eine I-Propertie anlegt in der steht auf welcher Farbe / welchem Layer diese Baugruppe nachher dargestellt werden soll. Auf diese Propertie könnte ein Makro zugfreifen und dann automatsch alle Geometrien überarbeiten...

Da sich das Ganze bei unseren Projekten aber gottlob nicht so viel Arbeit ausmacht und ich kein VB beherrsche ist das Ganze bisher nur als Idee vorhanden...

------------------
mfg Siegfried Schachinger
http://www.tbschatz.at

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

---

Hallo Leute hab grad das gleiche Problem im 2010er!

Ist im bezug auf dieses Thema im IV2011 schon etwas besser?

------------------
mfg Ronald

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

---

Ich glaub nicht dass sich da was geändert hat, aber ohne lange herumprobieren einen Alternativvorschlag:
Mach den gesamten Bestand per Abgeleiteter Komponente zu einem einzigen Bauteil und färbe dies speziell ein, und die Neuteile werden zeichnerisch so gehandhabt wie es halt auf Technischen Zeichnungen üblich ist: Schwarz/Weiss mit Linienstärken und Positionsnummern.

------------------
mfg - Leo

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

---

Hallo

AK's haben aber den Nachteil, daß sie in der Stückliste ihre Struktur verheimlichen. Dann schon eher Ersatzobjekte erstellen.

Mit der Idee ein iProp in jedes Bauteil zu setzen, könnte man was machen. Ihr könntet mal testen in jedes Bauteil ein benutzerdefiniertes iProp "Layer" zu erstellen und mit "Bestand", "Neu" usw. zu füllen. In der IDW müssen gleichnamige Layer vorhanden sein, damit es funktioniert. Dann mal dieses Makro testen:

Code:

---

Option Explicit

Private Sub MoveToLayer()

'verschiebt Zeichnungslinien anhand des Wertes des benutzerdefinierten
'iProps "Layer" auf einen gleichnamigen Layer
'Dieser Layer muß vorhanden sein !!!

Dim oApp As Application
Set oApp = ThisApplication

Dim oDrawDoc As DrawingDocument
Set oDrawDoc = oApp.ActiveDocument

Dim oView As DrawingView
Dim oiProp As String
Dim oDrawCurve As DrawingCurve
Dim oDrawCurveSegment As DrawingCurveSegment
Dim oDrawCurvesEnum As DrawingCurvesEnumerator
Dim oCompOcc As ComponentOccurrence
Dim oTopCompOcc As ComponentOccurrence
Dim oRefedAssDoc As AssemblyDocument
Dim oRefedDoc As Document
Dim oCompOccProxy As ComponentOccurrenceProxy
Dim oLayer As Layer

For Each oView In oDrawDoc.ActiveSheet.DrawingViews
    Set oRefedAssDoc = oView.ReferencedDocumentDescriptor.ReferencedDocument
   
    For Each oCompOcc In oRefedAssDoc.ComponentDefinition.Occurrences
        'Ersatzobjekte lassen wir erstmal weg
        If oCompOcc.IsSubstituteOccurrence = False Then
            'Sichtbar muss sie sein, sonst darf sie nicht mit rein ... Höh, das reimt sich *lol*
            If oCompOcc.Visible = True Then
                ' Check if it's child occurrence (leaf node)
                If oCompOcc.SubOccurrences.Count = 0 Then
                    Set oRefedDoc = oCompOcc.Definition.Document
                    oiProp = oRefedDoc.PropertySets.Item(4).Item("Layer").Value
                    'Call oCompOcc.CreateGeometryProxy(oCompOcc, oCompOccProxy)
                    Set oDrawCurvesEnum = oView.DrawingCurves(oCompOcc)
       
                    For Each oLayer In oDrawDoc.StylesManager.Layers
                        If oLayer.Name = oiProp Then
                            Exit For
                        End If
                    Next
       
                    For Each oDrawCurve In oDrawCurvesEnum
                        For Each oDrawCurveSegment In oDrawCurve.Segments
                            If oDrawCurveSegment.HiddenLine = False Then
                                oDrawCurveSegment.Layer = oLayer
                            End If
                        Next
                    Next
                Else
                    'eine Ebene tiefer springen
                    Set oTopCompOcc = oCompOcc
                    Call processAllSubOcc(oTopCompOcc, oCompOcc, oView, oDrawDoc) ' subassembly
                End If
            End If
        End If
    Next
Next
End Sub

' This function is called for processing sub assembly.  It is called recursively
' to iterate through the entire assembly tree.
Private Sub processAllSubOcc(ByVal oTopCompOcc As ComponentOccurrence, ByVal oCompOcc As ComponentOccurrence, oView As DrawingView, oDrawDoc As DrawingDocument)

Dim oDrawCurvesEnum As DrawingCurvesEnumerator
Dim oDrawCurve As DrawingCurve
Dim oDrawCurveSegment As DrawingCurveSegment
Dim oSubCompOcc As ComponentOccurrence
Dim oRefedDoc As Document
Dim oiProp As String
Dim oLayer As Layer

For Each oSubCompOcc In oCompOcc.SubOccurrences
    'Ersatzobjekte lassen wir erstmal weg
    If oSubCompOcc.IsSubstituteOccurrence = False Then
        'Sichtbar muss sie sein, sonst darf sie nicht mit rein ... Höh, das reimt sich *lol*
        If oSubCompOcc.Visible = True Then
            ' Check if it's child occurrence (leaf node)
            If oSubCompOcc.SubOccurrences.Count = 0 Then
                Set oRefedDoc = oSubCompOcc.Definition.Document
                On Error Resume Next
                oiProp = oRefedDoc.PropertySets.Item(4).Item("Layer").Value
                If Not oiProp = "" Then
                    'Call oCompOcc.CreateGeometryProxy(oCompOcc, oCompOccProxy)
                    Set oDrawCurvesEnum = oView.DrawingCurves(oCompOcc)
       
                    For Each oLayer In oDrawDoc.StylesManager.Layers
                        If oLayer.Name = oiProp Then
                            Exit For
                        End If
                    Next
                    Set oDrawCurvesEnum = oView.DrawingCurves(oSubCompOcc)
                    If Not oDrawCurvesEnum Is Nothing Then
                        For Each oDrawCurve In oDrawCurvesEnum
                            For Each oDrawCurveSegment In oDrawCurve.Segments
                                If oDrawCurveSegment.HiddenLine = False Then
                                    oDrawCurveSegment.Layer = oLayer
                                End If
                            Next
                        Next
                    End If
                End If
            Else
                Call processAllSubOcc(oTopCompOcc, oSubCompOcc, oView, oDrawDoc)
            End If
        End If
    End If
Next

Set oDrawCurvesEnum = Nothing
Set oDrawCurve = Nothing
Set oSubCompOcc = Nothing
End Sub

---

------------------
MfG
RK

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

---

Hallo Zusammen,

die Idee des Makros finde ich ja spitze, allerdings habe ich beim Ausführen unter Inventor 2019 einen Fehler (ich meine mich erinnern zu können das ich diesen Code unter 2016 ausführen konnte und er funktionierte). Kann es sein das der Code für Inventor 2019 angepasst werden muss und mir könnte jemand behilflich sein? Oder gibt es für dieses Problem mittlerweile eine andere Lösung?

Gruß

Stefan

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

---

Hallo

Ich denke nicht das etwas angepasst werden muss. Wie lautet denn die Fehlermeldung?
Der Code ist auf das Nötigste beschränkt. Fehlerbehandlung und Vorprüfungen fehlen weitestgehend.
Mir ist jetzt direkt keine andere Lösung bekannt. Inventor kennt halt keine "Kanten von neuen Teilen".

------------------
MfG
Ralf

RKW Solutions GmbH
www.RKW-Solutions.com

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

---

Bauteile.zip

Hallo,

danke für das Feedback.  Hatte schon befürchtet hier schaut keiner rein.

Ich habe im Anhang mal meinen Ablauf rein gestellt. Meine Vorstellung oder mein Wunsch wäre ich gebe den Einzelteilen einer Baugruppe einen benutzerdefinierten iProperty Layer und danach wird dann mit dem Makro gesucht und die Bauteile entsprechend eingefärbt.
Hintergrund ist folgender, wir wollen Bauteile (sowohl IPT als auch IAM) von Zulieferern in der Zeichnung farblich hervorheben in den DWG Dateien. Also es kann vorkommen das eine Zeichnung nur eine IPT enthält die eingefärbt werden soll oder aber das eine Baugruppen auf einer Zeichnung eingefärbt werden soll. Und dann gibt es noch unsere gezeichneten Bauteile die ohne  ein Makro nach Inventor Standard eingefärbt werden sollen. Das ist unsere Idee und es wäre super wenn es hierfür eine Lösung geben würde, ansonsten muss unsere Bürohilfe ne Woche Bauteile händisch in den Inventor Zeichnungstool einfärben und auf Layer verschieben.

Gruß
Stefan

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

---

Hallo

Der erste Fehler entsteht, da das Makro nie dafür vorgesehen war Zeichnungsansichten von Bauteilen einzufärben Kann man aber ergänzen.
Der zweite Fehler entsteht, wenn ein Bauteil in der Baugruppe kein benutzderfiniertes iProperty hat. Kann man berücksichtigen.

Baugruppen mit einem iProp Layer könnte man auch berücksichtigen, aber wenn die enthaltenen Bauteile ebenfalls ein iProp Layer haben und da steht ein anderer Wert drin, welche Angabe gilt dann?

------------------
MfG
Ralf

RKW Solutions GmbH
www.RKW-Solutions.com

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

---

Hallo Ralf,

dann habe ich das Makro wohl falsch verstanden.
Aalso grundsätzliches wäre es dann so, die Baugruppe bekäme von uns das iProperty mit dem entsprechenden Layer bzw. das einzelne Bauteil. Die Bauteile innerhalb der Gruppe bekämen kein Layer iProp (wenn's aber nicht anders geht, dann würden wir das eben machen). Die Bauteile sind meist Konturvereinfachungen von Lieferanten (also Hüllgeometrien), denen kann recht simpel das iProp verpasst werden. Bei den Unterbaugruppen handelt es sich meist um vom Kunden bereitgestellt STEP Dateien, die beim Import in Inventor umgewandelt werden in IAM's. Hier wäre es auch in unserer Hand das iProp direkt auf die IAM anzuwenden.
Ich beschreibe das mal:
Von uns erstellte Baugruppe auf Zeichenblatt mit diversen Bauteilen und Unterbaugruppen bestehend aus:
Ein von uns erstelltes Bauteil innerhalb unserer Baugruppe. Diese Bauteil erhält kein iProp --> Layerübernahme aus Standard Inventor.
Direkt daneben ein Elektromotor als Hüllgeometrie (IPT) mit dem iProp Layer Elektro. iProp von uns in der IPT vergeben. Daneben dann direkt der Stahlbau vom Lieferanten (IAM). Der IAM verpassen wir das iProp Layer Stahl und schauen in die IPT ob kein anderer Wert eingetragen wurde.
Heraus kommt das von uns gezeichnete Bauteil in schwarz auf Layer Kontur, daneben der Elektromotor in rot auf Layer Elektro und dann zu guter Letzt der Stahlbau in blau auf Layer Stahl

Ich hoffe das ist nicht zu kompliziert erklärt und man versteht was ich suche. Wenn ein Beispiel helfen sollte, könnte ich eines erstellen.

Gruß

Stefan

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

---

Hallo

Das lässt sich meiner Meinung alles so umsetzen. Zusätzlich würde ich einfach sagen, wenn in der Baugruppe Stahlbau ein iProp vorhanden ist, wird das genommen und in den Unterbaugruppen und Bauteilen gar nicht mehr weiter gesucht. Das spart etwas Laufzeit. Und ihr müsst nicht die untergeordneten Baugruppen/Bauteile durchsuchen und dort vorhandene iProps entfernen. Es gewinnt einfach das iProp, dass in der Baugruppenhierarchie am weitesten oben steht. Einfach mal probieren, sind sicher Kinderkrankheiten drin.

Code:

---

Option Explicit

Private Const cPropName As String = "Layer"

Private Sub MoveToLayer()
    Dim oApp As Inventor.Application
    Set oApp = ThisApplication
   
    If oApp.Documents.Count = 0 Or Not oApp.ActiveDocumentType = kDrawingDocumentObject Then
        MsgBox "Funktion nur in Zeichnungsableitungen möglich.", vbCritical, "MoveToLayer"
        Exit Sub
    End If
   
    Dim oDrawDoc As DrawingDocument
    Set oDrawDoc = oApp.ActiveDocument
   
    If MsgBox("Alle Blätter aktualisieren?", vbYesNo, "MoveToLayer") = vbYes Then
        Call UpdateAllSheets(oDrawDoc)
    Else
        Call UpdateAllViews(oDrawDoc.ActiveSheet)
    End If
   
    MsgBox "Fertig", vbInformation, "MoveToLayer"
End Sub

Private Sub UpdateAllSheets(ByVal oDrawDoc As DrawingDocument)
    Dim oActiveSheet As Sheet
    Set oActiveSheet = oDrawDoc.ActiveSheet
   
    Dim oSheet As Sheet
    For Each oSheet In oDrawDoc.Sheets
        oSheet.Activate
        Call UpdateAllViews(oSheet)
        oSheet.Update
    Next
   
    Call oActiveSheet.Activate
End Sub

Private Sub UpdateAllViews(ByVal oSheet As Sheet)
    Dim oView As DrawingView
    For Each oView In oSheet.DrawingViews
        Call UpdateView(oSheet, oView)
    Next
End Sub

Private Sub UpdateView(ByVal oSheet As Sheet, ByVal oView As DrawingView)
    If oView.ReferencedDocumentDescriptor.ReferencedDocumentType = kAssemblyDocumentObject Then
        Call ProcessAss(oView.ReferencedDocumentDescriptor.ReferencedDocument, oSheet, oView)
    ElseIf oView.ReferencedDocumentDescriptor.ReferencedDocumentType = kPartDocumentObject Then
        Call ProcessPart(oView.ReferencedDocumentDescriptor.ReferencedDocument, oSheet, oView)
    End If
End Sub

Private Sub ProcessPart(ByVal oPartDoc As PartDocument, ByVal oSheet As Sheet, ByVal oView As DrawingView)
    Dim sLayer As String
    sLayer = GetPropValue(oPartDoc, cPropName)
   
    If sLayer = "" Then Exit Sub
   
    Dim oLayer As Layer
    Set oLayer = GetLayer(sLayer)
   
    If oLayer Is Nothing Then Exit Sub
   
    Dim oDrawCurves As DrawingCurvesEnumerator
    Set oDrawCurves = oView.DrawingCurves()
   
    If Not oDrawCurves Is Nothing Then
        Dim oDrawCurveSegColl As ObjectCollection
        Set oDrawCurveSegColl = GetAllCurveSegs(oDrawCurves)
       
        Call oSheet.ChangeLayer(oDrawCurveSegColl, oLayer)
    End If
End Sub

Private Sub ProcessAss(ByVal oAssDoc As AssemblyDocument, ByVal oSheet As Sheet, ByVal oView As DrawingView)
    Dim sLayer As String
    sLayer = GetPropValue(oAssDoc, cPropName)
   
    If Not sLayer = "" Then ' ### Variante A - Hauptbaugruppe hat iProp Layer
        Dim oLayer As Layer
        Set oLayer = GetLayer(sLayer)
   
        If Not oLayer Is Nothing Then
            Dim oDrawCurves As DrawingCurvesEnumerator
            Set oDrawCurves = oView.DrawingCurves()
           
            If Not oDrawCurves Is Nothing Then
                Dim oDrawCurveSegColl As ObjectCollection
                'Set oDrawCurveSegColl = ThisApplication.TransientObjects.CreateObjectCollection
                Set oDrawCurveSegColl = GetAllCurveSegs(oDrawCurves)
               
                Call oSheet.ChangeLayer(oDrawCurveSegColl, oLayer)
            End If
        End If
    Else
        Dim oCompOccs As ComponentOccurrences
        Set oCompOccs = oAssDoc.ComponentDefinition.Occurrences
        Call ProcessAllOccs(oCompOccs, oSheet, oView)
    End If
End Sub

Private Sub ProcessOcc(ByVal oCompOcc As ComponentOccurrence, ByVal oSheet As Sheet, ByVal oView As DrawingView)
    Dim oRefedDoc As Document
    Set oRefedDoc = oCompOcc.Definition.Document
   
    Dim sLayer As String
    sLayer = GetPropValue(oRefedDoc, cPropName)
   
    If sLayer = "" Then Exit Sub
   
    Dim oLayer As Layer
    Set oLayer = GetLayer(sLayer)
   
    If oLayer Is Nothing Then Exit Sub
   
    Dim oDrawCurves As DrawingCurvesEnumerator
    Set oDrawCurves = oView.DrawingCurves(oCompOcc)
   
    If Not oDrawCurves Is Nothing Then
        Dim oDrawCurveSegColl As ObjectCollection
        Set oDrawCurveSegColl = GetAllCurveSegs(oDrawCurves)
       
        Call oSheet.ChangeLayer(oDrawCurveSegColl, oLayer)
    End If
End Sub

Private Sub ProcessAllOccs(ByVal oCompOccs As ComponentOccurrences, ByVal oSheet As Sheet, ByVal oView As DrawingView)
    Dim oCompOcc As ComponentOccurrence
    For Each oCompOcc In oCompOccs
        If oCompOcc.IsSubstituteOccurrence = False Then
            If oCompOcc.Visible = True Then
                If oCompOcc.SubOccurrences.Count = 0 Then 'Part (or empty Assembly!!!)
                    If oCompOcc.DefinitionDocumentType = kPartDocumentObject Then
                        Call ProcessOcc(oCompOcc, oSheet, oView)
                    End If
                Else
                    Dim oRefedDoc As Document
                    Set oRefedDoc = oCompOcc.Definition.Document
   
                    Dim sLayer As String
                    sLayer = GetPropValue(oRefedDoc, cPropName)
                   
                    If sLayer = "" Then
                        Call ProcessAllOccs(oCompOcc.SubOccurrences, oSheet, oView)
                    Else
                        Call ProcessOcc(oCompOcc, oSheet, oView)
                    End If
                End If
            End If
        End If
    Next
End Sub

Private Function GetPropValue(ByVal oDoc As Document, ByVal sPropName As String) As String
    Dim oPropSet As PropertySet
    Set oPropSet = oDoc.PropertySets.Item("{D5CDD505-2E9C-101B-9397-08002B2CF9AE}") 'user defined properties

    Dim oProp As Property
    For Each oProp In oPropSet
        If oProp.Name = sPropName Then
            GetPropValue = oProp.Value
            Exit For
        End If
    Next
End Function

Private Function GetAllCurveSegs(ByVal oDrawCurves As DrawingCurvesEnumerator) As ObjectCollection
    Dim oDrawCurve As DrawingCurve
    Dim oDrawCurveSegment As DrawingCurveSegment
    Dim oDrawCurveSegColl As ObjectCollection
    Set oDrawCurveSegColl = ThisApplication.TransientObjects.CreateObjectCollection
   
    For Each oDrawCurve In oDrawCurves
        For Each oDrawCurveSegment In oDrawCurve.Segments
            If oDrawCurveSegment.HiddenLine = False And oDrawCurveSegment.Visible = True Then
                Call oDrawCurveSegColl.Add(oDrawCurveSegment)
            End If
        Next
    Next
   
    Set GetAllCurveSegs = oDrawCurveSegColl
End Function

Private Function GetLayer(ByVal sLayer As String) As Layer
    Dim oDrawDoc As DrawingDocument
    Set oDrawDoc = ThisApplication.ActiveDocument
   
    Dim oLayer As Layer
    For Each oLayer In oDrawDoc.StylesManager.layers
        If oLayer.Name = sLayer Then
            Set GetLayer = oLayer
            Exit For
        End If
    Next
   
    If GetLayer Is Nothing Then
        If MsgBox("Layer " & sLayer & " nicht gefunden. Neu anlegen?", vbQuestion + vbYesNo, "MoveToLayer") = vbYes Then
            Set GetLayer = CreateLayer(sLayer)
        End If
    End If
End Function

Private Function CreateLayer(ByVal sLayer As String) As Layer
    Dim oDrawDoc As DrawingDocument
    Set oDrawDoc = ThisApplication.ActiveDocument
   
    Dim oNewLayer As Layer
    Set oNewLayer = oDrawDoc.StylesManager.layers.Item(1).Copy(sLayer)
   
    oNewLayer.LineType = kContinuousLineType
    oNewLayer.color = ThisApplication.TransientObjects.CreateColor(255, 0, 0)
    oNewLayer.LineWeight = 0.05
    oNewLayer.ScaleByLineWeight = True
    oNewLayer.Visible = True
    oNewLayer.Plot = True
   
    Set CreateLayer = oNewLayer
End Function

---

------------------
MfG
Ralf

RKW Solutions GmbH
www.RKW-Solutions.com

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

---

Hallo Ralf,

vielen Dank für das super Makro. Das funktioniert ja echt super. Allerdings habe ich grade beim testen herausgefunden das es noch einen kleineren Bug gibt. Ich habe zum Testen mal einer Baugruppe ein iProp gegeben und das wurde auch entsprechend eingefärbt, aber nachdem ich das iProp wieder entfernt hatte, wird diese Layer Änderung nicht mehr rückgängig gemacht. Sprich die Bauteile sind jetzt immernoch auf dem Layer Stahl. Da war ich mit dem Testen wohl zu voreilig. Gibt es da eine Möglichkeit eine Funktion einzubauen die erstmal alle Layer wider auf Standard setzt und dann neu einfärbt bzw. die schaut ob sich ein iProp geändert hat und macht die Änderungen wieder rückgängig?

Gruß und echt vielen Dank

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

---

Hallo

Man kann die Layer zurücksetzen. Das Makro setzt alle Linien zurück auf "nach Norm". Ihr habt hoffentlich keine weiteren Überschreibungen der Layer in euren Zeichnungen, denn die würden mit platt gemacht.
Ein Resync bzw. ein generelles Zurücksetzen vor jedem Zuweisen würde deutlich die Laufzeit erhöhen. Ich weiß nicht wie groß eure Zeichnungen sind, aber das kann dann mehrere Minuten dauern.
Ich habe beim Zurücksetzen immer wieder in meiner Testbaugruppe Linien gehabt, die nicht zurückgesetzt wurden. Die Ursache dafür konnte ich noch nicht finden. Wenn man sie manuell ausgewählt und auf "nach Norm" gesetzt hat, ging das problemlos.

Code:

---

Private Sub ResetLayers()
    Dim oApp As Inventor.Application
    Set oApp = ThisApplication
   
    If oApp.Documents.Count = 0 Or Not oApp.ActiveDocumentType = kDrawingDocumentObject Then
    MsgBox "Funktion nur in Zeichnungsableitungen möglich.", vbCritical, "ResetLayer"
    Exit Sub
    End If
   
    Dim oDrawDoc As DrawingDocument
    Set oDrawDoc = oApp.ActiveDocument
   
    If MsgBox("Alle Blätter zurücksetzen?", vbYesNo, "ResetLayer") = vbYes Then
        Call ResetAllSheets(oDrawDoc)
    Else
        Call ResetAllViews(oDrawDoc.ActiveSheet)
    End If
   
    MsgBox "Fertig", vbInformation, "ResetLayer"
End Sub

Private Sub ResetAllSheets(ByVal oDrawDoc As DrawingDocument)
    Dim oActiveSheet As Sheet
    Set oActiveSheet = oDrawDoc.ActiveSheet
   
    Dim oSheet As Sheet
    For Each oSheet In oDrawDoc.Sheets
        oSheet.Activate
        Call ResetAllViews(oSheet)
    Next
   
    Call oActiveSheet.Activate
End Sub

Private Sub ResetAllViews(ByVal oSheet As Sheet)
    Dim oView As DrawingView
    For Each oView In oSheet.DrawingViews
        Call ResetView(oSheet, oView)
    Next
End Sub

Private Sub ResetView(ByVal oSheet As Sheet, ByVal oView As DrawingView)
    Dim oDrawCurves As DrawingCurvesEnumerator
    Set oDrawCurves = oView.DrawingCurves()
   
    If Not oDrawCurves Is Nothing Then
        Dim oDrawCurveSegColl As ObjectCollection
        Set oDrawCurveSegColl = GetAllResetCurveSegs(oDrawCurves)
       
        Call ThisApplication.ActiveDocument.SelectSet.Clear
        Call ThisApplication.ActiveDocument.SelectSet.SelectMultiple(oDrawCurveSegColl)
       
        Call oSheet.ChangeLayer(oDrawCurveSegColl, Nothing)
       
        Call ThisApplication.ActiveDocument.SelectSet.Select(oView)
        Call ThisApplication.CommandManager.ControlDefinitions("AppLocalUpdateCmd").Execute
    End If
End Sub

Private Function GetAllResetCurveSegs(ByVal oDrawCurves As DrawingCurvesEnumerator) As ObjectCollection
    Dim oDrawCurve As DrawingCurve
    Dim oDrawCurveSegment As DrawingCurveSegment
    Dim oDrawCurveSegColl As ObjectCollection
    Set oDrawCurveSegColl = ThisApplication.TransientObjects.CreateObjectCollection
   
    For Each oDrawCurve In oDrawCurves
        For Each oDrawCurveSegment In oDrawCurve.Segments
            If oDrawCurveSegment.HiddenLine = False And oDrawCurveSegment.Visible = True Then
                Call oDrawCurveSegColl.Add(oDrawCurveSegment)
            End If
        Next
    Next
   
    Set GetAllResetCurveSegs = oDrawCurveSegColl
End Function

---

------------------
MfG
Ralf

RKW Solutions GmbH
www.RKW-Solutions.com

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

---

Ggf. kann man ja mit einer temporären "Sicherung" auf einer zweiten Seite arbeiten?
Also unberührtes Original auf Seite 1 und die Ansichten mit den modifizierten Layern auf Seite 2.

VG
MB-Ing.

------------------
Wissen ist Macht. Nichts wissen macht auch nichts 

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

---

Hallo Ralf,

du bist der Beste. Vielen Vielen Dank. Mit dem zweiten Makro konnte ich meine verpfuschte Zeichnung wiederherstellen und im Anschluss entsprechend einfärben. Genau so habe ich mir das vorgestellt.
Und die fünf Minuten, die die zwei Makros benötigen zum bereinigen und einfärben, sind immernoch Tage weniger wie händisch anpassen.

Vielen Dank.

Gruß
Stefan

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