---

Hallo zusammen

Ich habe eine Zeichnung einer Baugruppe als idw. In der Baugruppe sind mehrere Bauteile zusammengefasst in verschiedenen Ordnern.
Ist es möglich, in VBA zu eruieren in welchem Ordner sich die Bauteile befinden und damit eine If-Schleife zu erstellen?

Hintergrund ist, über die Ordnerzugehörigkeit die Layer der jeweiligen Bauteile anzupassen.

Beste Grüsse
Raphael

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

---

Es gibt die Versuchung auf diese Frage einfach mit JA zu antworten, was Dir aber vmtl. nicht wirklich weiter hilft.

Man hat über die Zeichnung (bzw. Kanten darin) die Möglichkeit auf das Modell (hier die Baugruppe) und darüber auf die Einzelteile Zugriff zu erlangen. Die Einzelteile "wissen" auch wo sie gespeichert sind.

Jetzt hilft Dir das etwas ausführlichere JA, vielleicht auch nicht mehr.

------------------
Gruß KraBBy

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

---

hier wird etwas rumhantiert mit Kanten aus einer IDW um zur Bgr.Komp. zu gelangen. Evtl. hilfts
Pick-Methode in idw für ein Bauteil

Und hier auch meine "Minimal-Demonstration" (nicht groß rumprobiert, Stolperfallen sind wahrscheinlich):

Code:

---

Sub idw_Pfad_von_Kante()
' in einer aktiven Zeichnung, darin mindestens eine Ansicht einer Baugruppe
    Dim oSel As SelectSet
    Set oSel = ThisApplication.ActiveDocument.SelectSet
   
    'ein Kante muss ausgewählt sein
    Dim oKante As Object
    If Not 0 = oSel.Count Then Set oKante = oSel.Item(1) Else Exit Sub
   
    'gewähltes Objekt ist vom Typ DrawingCurveSegment
    Dim oDrwCurveSegment As DrawingCurveSegment
    Set oDrwCurveSegment = oKante
   
    'oDrwCurveSegment.Parent 'liefert eine DrawingCurve
    'oDrwCurveSegment.Parent.ModelGeometry  'Object/EdgeProxy (je nach gewählter Kante)
    Dim oOcc As ComponentOccurrence
    Set oOcc = oDrwCurveSegment.Parent.ModelGeometry.ContainingOccurrence 'ComponentOccurrence, die Komponente der Baugruppe
   
    Dim sDateinamePfad As String
    sDateinamePfad = oOcc.Definition.Document.fullFilename
   
    MsgBox sDateinamePfad
    Stop
   
End Sub

---

------------------
Gruß KraBBy

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

---

noch eine Kleinigkeit: Wie willst Du Unterbaugruppen handhaben? die haben auch einen Speicherort. Liefern aber i.d.R. keine Kanten (außer evtl. bei Bgr.Bearbeitungen ... kA)

------------------
Gruß KraBBy

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

---

Hallo,

ein Ansatz über die Zeichenansicht an Bauteile im Ordner zu gelangen.

Code:

---

Sub BrowserFolderDrawing()
    Dim oApp As Inventor.Application
    Set oApp = ThisApplication
   
    Dim oDoc As Inventor.DrawingDocument
    Set oDoc = oApp.ActiveDocument

    Dim oBrowserNode As BrowserNode
    Dim oBrowserFolders As BrowserFoldersEnumerator
    Dim oDrwView As DrawingView
    Set oDrwView = oDoc.ActiveSheet.DrawingViews.Item(1)
    Set oBrowserFolders = oDrwView.ReferencedDocumentDescriptor.ReferencedDocument.BrowserPanes.ActivePane.TopNode.BrowserFolders
    Dim oBrowserFolder As BrowserFolder
   
    For Each oBrowserFolder In oBrowserFolders
        Debug.Print oBrowserFolder.Name
        For Each oBrowserNode In oBrowserFolder.BrowserNode.BrowserNodes
            Debug.Print oBrowserNode.FullPath
        Next
    Next
   
End Sub

---

Dann Auswahl als Kanten und Layer bearbeiten.

Grüße und schönes WE

EIBe 3D

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

---

Ordnerstruktur.JPG

Hallo KraBBy

Lass dich nicht von der Versuchung leiten und mach so ausführlich weiter wie bis anhin 
Vielen Dank bereits für deine Ausführungen. Ich habe mich anscheinend zu wenig präzise ausgedrückt. Ich meine nicht die Ordner der Pfadstruktur sondern die Ordner welche man in der Baugruppe im Strukturbaum erstellen kann um sich besser zu organisieren.
Ich weiss einfach nicht wonach ich suchen kann um in VBA eine Zugehörigkeit eines Bauteil zu einem Ordner mit "Ordnername" zu finden.

Edit: (den letzten Satz fertig geschrieben)

[Diese Nachricht wurde von OibelTroibel am 19. Feb. 2021 editiert.]

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

---

Hallo ElBe 3D

Super, herzlichen Dank für dein Gedankenanstoss. Das sollte mir vom durchlesen auf jeden fall weiterhelfen

Grüsse und dir auch ein schönes Wochenende
Raphael

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

---

Schon länger ist es her, nun wieder aktueller. In einem anderen Thread hat mir Ralf auf einen interessanten Link hingewiesen.
Ich habe versucht, die Ordnerzugehörigkeit gemäss ElBe 3D zu nutzen um dann die Layer der entsprechenden Bauteile gemäss Ordnerzugehörigkeit zu ändern.
Leider scheint mir die BrowserNodes als Sackgasse, die keine Steuerung der Layer der enthaltenen Bauteile zulässt. Oder wie stelle ich da eine Verknüpfung zu den eigentlichen Bauteilen her?

Beste Grüsse
Raphael

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

---

Hallo Raphael,

du kannst einem Bauteil kein Layer zuweisen. Nur den, dem Bauteil zugehörigen dargestellten Kanten (drawing curves)

ich zitiere mich mal selbst:

Zitat:

---

... Dann Auswahl als Kanten und Layer bearbeiten

---

Auch in dem verlinkten Beispiel wird entsprechend vorgegangen.

So soltest du prinzipiell an die entsprechenden BrowserNodes kommen und sie per oBrowserNode.DoSelect ansprechen können

Code:

---

Sub BrowserNodeDrawing()

    Dim oApp As Inventor.Application
    Set oApp = ThisApplication
 
    Dim oDoc As Inventor.DrawingDocument
    Set oDoc = oApp.ActiveDocument

    Dim oBrowserNode As Inventor.BrowserNode
    Dim oBrowserFolders As BrowserFoldersEnumerator
    Dim oDrwView As DrawingView
    Set oDrwView = oDoc.ActiveSheet.DrawingViews.Item(1)
    Set oBrowserFolders = oDrwView.ReferencedDocumentDescriptor.ReferencedDocument.BrowserPanes.ActivePane.TopNode.BrowserFolders
    Dim oBrowserFolder As BrowserFolder
   

    For Each oBrowserFolder In oBrowserFolders
        If oBrowserFolder.name = "Normteile" Then 'Ordnername anpassen
            For Each oBrowserNode In oBrowserFolder.BrowserNode.BrowserNodes
   
                'funktioniert nicht
                'oBrowserNode.Expanded = True 'crasht
                Call oBrowserNode.DoSelect ' dieserer Befehl wird nicht korrekt ausgeführt sonst würde es laufen
                '***
                Call oApp.CommandManager.ControlDefinitions.Item("SelectAsEdgesCtxCmd").Execute 'Hier bekommst du alle Kanten auf einmal; Haltepunkt setzen und BrowserNode von Hand waählen
               
                MsgBox oDoc.SelectSet.Count
               
                Dim oCurSegment As DrawingCurveSegment
                For Each oCurSegment In oDoc.SelectSet
                    'oCurSegment.Layer = WunschLayer 'Leg dein CurveSegment auf ein Layer
                    oCurSegment.Visible = False 'Mach was zum Test, einblenden klappt scheinbar nicht
                    'Stop
                Next
               
                MsgBox oBrowserNode.NativeObject.name 'Deine Bauteile im Ordner
               
            Next
        End If
    Next
   
    Call oDoc.Update2(True)
   
End Sub

---

Dummerweise scheitert bei mir das oBrowserNode.DoSelect und ich weiß nicht warum. Da müsstest du dich mal durchtesten. Wähle ich das Bauteil dort wo in den Kommentaren geschrieben per Hand vor komme ich an alle DrawingCurveSegments.

Grüße

EIBe 3D

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

---

Hallo ElBe 3D

Vielen herzlichen Dank für den Code und das Testen. Ich schau mir den Code an und probiere es zum laufen zu kriegen

Ich wünsche dir ein schönes Wochenende

Beste Grüsse
Raphael

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

---

Hallo

Du definierst das BrowserPane als das des referenzierten Dokumentes, also der Baugruppe. Auf den Node kann man, wenn die Zeichnung aktiv ist, schlicht nicht klicken. 
Ich hab's mal angepasst.

Code:

---

Sub BrowserNodeDrawing()

    Dim oApp As Inventor.Application
    Set oApp = ThisApplication

    Dim oDoc As Inventor.DrawingDocument
    Set oDoc = oApp.ActiveDocument

    Dim oDrwView As DrawingView
    Set oDrwView = ThisApplication.CommandManager.Pick(kDrawingViewFilter, "Ansicht auswählen")
   
    Dim oDrwViewNodeDef As NativeBrowserNodeDefinition
    Set oDrwViewNodeDef = oDoc.BrowserPanes.GetNativeBrowserNodeDefinition(oDrwView)

    Dim oTopNode As BrowserNode
    Set oTopNode = oDoc.BrowserPanes.ActivePane.TopNode
   
    Dim oBrowserNodesEnum As BrowserNodesEnumerator
    Set oBrowserNodesEnum = oTopNode.AllReferencedNodes(oDrwViewNodeDef)
   
    Dim oBrowserNode As Inventor.BrowserNode
    Dim oBrowserFolders As BrowserFoldersEnumerator
       
    Set oBrowserFolders = oBrowserNodesEnum.Item(1).BrowserNodes.Item(1).BrowserFolders
    Dim oBrowserFolder As BrowserFolder

    For Each oBrowserFolder In oBrowserFolders
        If oBrowserFolder.Name = "Normteile" Then 'Ordnername anpassen
            For Each oBrowserNode In oBrowserFolder.BrowserNode.BrowserNodes
                Call oBrowserNode.DoSelect ' dieserer Befehl wird nicht korrekt ausgeführt sonst würde es laufen
                Call oApp.CommandManager.ControlDefinitions.Item("SelectAsEdgesCtxCmd").Execute 'Hier bekommst du alle Kanten auf einmal; Haltepunkt setzen und BrowserNode von Hand waählen
               
                MsgBox oDoc.SelectSet.Count
             
                Dim oCurSegment As DrawingCurveSegment
                For Each oCurSegment In oDoc.SelectSet
                    'oCurSegment.Layer = WunschLayer 'Leg dein CurveSegment auf ein Layer
                Next
               
                MsgBox oBrowserNode.NativeObject.Name 'Deine Bauteile im Ordner
            Next
        End If
    Next
 
    Call oDoc.Update2(True)
 
End Sub

---

Ich hatte das Ganze schon etwas weiter gesponnen gehabt, nur fehlte wieder mal die Zeit es fertig zu machen. Da ich es schon öfter erlebt habe, dass der Modellbrowser in der IDW nur ein "generisches Objekt" zurückliefert mit dem man nix anfangen kann, bin ich gleich in die Baugruppe mit meinem Vorschlag. Den Kram rekursiv zu machen hat es ganz schön aufgeblasen. 

Code:

---

Private Sub SwitchLayerByFolder()

    Dim oDrawDoc As DrawingDocument
    Set oDrawDoc = ThisApplication.ActiveDocument
   
    Dim oDrawView As DrawingView
    Set oDrawView = ThisApplication.CommandManager.Pick(kDrawingViewFilter, "Anicht auswählen")
   
    If CheckDrawView(oDrawView) = False Then
        Exit Sub
    End If
   
    Call ResetLayers(oDrawView)
   
    Dim oAssDoc As AssemblyDocument
    Set oAssDoc = oDrawView.ReferencedDocumentDescriptor.ReferencedDocument
   
    Dim oBrowserPane As BrowserPane
    Set oBrowserPane = oAssDoc.BrowserPanes.Item("AmBrowserArrangement")
   
    Dim oTopNode As BrowserNode
    Set oTopNode = oBrowserPane.TopNode
   
    Dim oFolder As BrowserFolder
    For Each oFolder In oTopNode.BrowserFolders
        Call TraverseBrowserFolder(oAssDoc, oDrawView, oFolder)
    Next
   
    Call TraverseBrowserNodes(oAssDoc, oDrawView, oTopNode)
   
    MsgBox ("Done")

End Sub
   
Private Sub TraverseBrowserNodes(ByVal oAssDoc As AssemblyDocument, ByVal oDrawView As DrawingView, ByVal oBrowserNode As BrowserNode)
   
    Dim oFolder As Inventor.BrowserFolder
    Dim oNode As Inventor.BrowserNode
    For Each oNode In oBrowserNode.BrowserNodes
        'wir interessieren uns derzeit nur für BrowserNodes in BrowserFoldern
        ' "normale" Nodes ignorieren wir einfach
        'Call ProcessBrowserNode(oNode)
       
        For Each oFolder In oNode.BrowserFolders
            Call TraverseBrowserFolder(oAssDoc, oDrawView, oFolder)
        Next
       
        Call TraverseBrowserNodes(oAssDoc, oDrawView, oNode)
    Next
   
End Sub

Private Sub TraverseBrowserFolder(ByVal oAssDoc As AssemblyDocument, ByVal oDrawView As DrawingView, ByVal oBrowserFolder As BrowserFolder)
   
    Dim sName As String
    Dim oNode As BrowserNode
    Dim oBrowserNode As BrowserNode
    Set oBrowserNode = oBrowserFolder.BrowserNode
   
    Dim oObj As Object
    For Each oNode In oBrowserNode.BrowserNodes
        Set oObj = GetBrowserFolderItem(oNode)
        If Not oObj Is Nothing Then
            'If oObj.DefinitionDocumentType = kPartDocumentObject Then '<-- aktivieren, um nur Bauteile zu berücksichtigen
                Dim oDrawCurves As DrawingCurvesEnumerator
                Set oDrawCurves = oDrawView.DrawingCurves(oObj)
                If Not oDrawCurves Is Nothing Then
                    Dim oLayer As Layer
                    Set oLayer = GetLayer(oDrawView, oBrowserFolder.Name)  '<--FolderName als Layername? Notfalls neu erstellen?
                   
                    Dim oDrawCurveSegmentsColl As ObjectCollection
                    Set oDrawCurveSegmentsColl = ThisApplication.TransientObjects.CreateObjectCollection
                   
                    Dim oDrawCurve As DrawingCurve
                    Dim oDrawCurveSegment As DrawingCurveSegment
                    For Each oDrawCurve In oDrawCurves
                        For Each oDrawCurveSegment In oDrawCurve.Segments
                            If oDrawCurveSegment.Visible = True Then
                                If oDrawCurveSegment.HiddenLine = False Then
                                    Call oDrawCurveSegmentsColl.Add(oDrawCurveSegment)
                                End If
                            End If
                        Next
                    Next
                    Call oDrawView.Parent.ChangeLayer(oDrawCurveSegmentsColl, oLayer)
                    Set oDrawCurves = Nothing
                End If
            'End If
        End If
        Set oObj = Nothing
    Next
   
    Dim oFolder As Inventor.BrowserFolder
    For Each oFolder In oBrowserNode.BrowserFolders
        Call TraverseBrowserFolder(oAssDoc, oDrawView, oFolder)
    Next
       
End Sub

Private Function GetBrowserFolderItem(ByVal oBrowserNode As BrowserNode) As Object
   
    Select Case oBrowserNode.NativeObject.Type
        Case kComponentOccurrenceObject:
                Set GetBrowserFolderItem = oBrowserNode.NativeObject
        Case kRectangularOccurrencePatternObject:
                Set GetBrowserFolderItem = oBrowserNode.NativeObject
        Case kCircularOccurrencePatternObject:
                Set GetBrowserFolderItem = oBrowserNode.NativeObject
        Case kComponentOccurrenceProxyObject:
                Set GetBrowserFolderItem = oBrowserNode.NativeObject
        Case kRectangularOccurrencePatternProxyObject:
                Set GetBrowserFolderItem = oBrowserNode.NativeObject
        Case kCircularOccurrencePatternProxyObject:
                Set GetBrowserFolderItem = oBrowserNode.NativeObject
        Case kBrowserFolderObject:
                'nix machen
        Case Else:
                MsgBox ("unknown")
    End Select
   
End Function

Private Function GetLayer(ByVal oDrawView As DrawingView, ByVal sFolderName As String) As Layer
   
    Dim oDrawDoc As DrawingDocument
    Set oDrawDoc = oDrawView.Parent.Parent
   
    On Error Resume Next
    Set GetLayer = oDrawDoc.StylesManager.layers.Item(sFolderName)
    On Error GoTo 0
    If GetLayer Is Nothing Then
        Set GetLayer = CreateLayer(oDrawDoc, sFolderName, kContinuousLineType, 255, 0, 0)
    End If
   
End Function

Private Function CreateLayer(ByVal oDrawDoc As DrawingDocument, ByVal sLayerName As String, ByVal eLineType As Inventor.LineTypeEnum, ByVal iRed As Integer, ByVal iGreen As Integer, ByVal iBlue As Integer) As Layer

    Dim oStylesManager As DrawingStylesManager
    Set oStylesManager = oDrawDoc.StylesManager

    Dim oColor As Inventor.color
    Set oColor = ThisApplication.TransientObjects.CreateColor(CByte(iRed), CByte(iGreen), CByte(iBlue))

    Dim oLayer As Layer
    Set oLayer = oStylesManager.layers.Item(1).Copy(sLayerName)
    With oLayer
        .LineType = eLineType
        .color = oColor
        .LineWeight = 0.05
        .ScaleByLineWeight = True
    End With
   
    Set CreateLayer = oLayer

End Function

Private Function CheckDrawView(ByVal oDrawView As DrawingView) As Boolean
    'Vorprüfungen einer Zeichgnungsansicht
   
    'Ansicht iO
    CheckDrawView = True
   
    'oder doch nicht?
   
    'Ist die Ansicht unterdrückt?
    If oDrawView.Suppressed = True Then CheckDrawView = False
   
    'gerasterte Ansicht kann man eh nicht
    If oDrawView.IsRasterView = True Then CheckDrawView = False

    'Entwurfsansichten haben kein assoziiertes 3D-Modell
    If oDrawView.ViewType = DrawingViewTypeEnum.kDraftDrawingViewType Then CheckDrawView = False

    'In Schnittansichten fehlen immer wieder nicht reproduzierbar Kanten
    If oDrawView.ViewType = DrawingViewTypeEnum.kSectionDrawingViewType Then CheckDrawView = False

    'Ist das 3D-Modell aktuell oder stehen Aktualisierung aus?
    Dim oDoc As Document
    Set oDoc = oDrawView.ReferencedDocumentDescriptor.ReferencedDocument
   
    If Not oDoc.DocumentType = kAssemblyDocumentObject Then
        Call MsgBox("Die Ansicht muss eine Baugruppe referenzieren.", vbCritical)
        CheckDrawView = False
        Return
    End If
       
       
    If oDoc.RequiresUpdate = True Then
        If MsgBox("Das Modell muss aktualisiert werden. Aktualisieren und fortfahren?", vbYesNo) = vbNo Then
            CheckDrawView = False
        End If
        Call oDoc.Update
    End If

End Function

Private Sub ResetLayers(ByVal oDrawView As DrawingView)

    Dim oDrawCurveSegmentsColl As ObjectCollection
    Set oDrawCurveSegmentsColl = ThisApplication.TransientObjects.CreateObjectCollection
   
    Dim oDrawCurve As DrawingCurve
    Dim oDrawCurveSegment As DrawingCurveSegment
   
    For Each oDrawCurve In oDrawView.DrawingCurves
        For Each oDrawCurveSegment In oDrawCurve.Segments
            If oDrawCurveSegment.Visible = True Then
                If oDrawCurveSegment.HiddenLine = False Then
                    Call oDrawCurveSegmentsColl.Add(oDrawCurveSegment)
                End If
            End If
        Next
    Next
   
    Dim oLayer As Layer
    Call oDrawView.Parent.ChangeLayer(oDrawCurveSegmentsColl, oLayer)
   
End Sub

---

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

RKW Solutions GmbH
www.RKW-Solutions.com

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

---

Hallo zusammen,

@Ralf: Danke für deine Korrektur, irgendwie habe ich die AllReferencedNodes Abzweigung vollständig übersehen und wäre vermutlich noch wahnsinnig geworden.

Nun klappt zumindest in kurzen Tests unterer Code wie ursprünglich von mir gedacht.

Code:

---

Sub BrowserNodeDrawing()

    Dim oApp As Inventor.Application
    Set oApp = ThisApplication

    Dim oDrwDoc As Inventor.DrawingDocument
    Set oDrwDoc = oApp.ActiveDocument
   
    Dim oSheet As Sheet
    Set oSheet = oDrwDoc.ActiveSheet
   
    Dim oDrwView As DrawingView
   
    Dim oTrans As Transaction
    Set oTrans = oApp.TransactionManager.StartTransaction(oDrwDoc, "Unterdrücke Normteilkanten")
   
    For Each oDrwView In oSheet.DrawingViews
 
        Dim oDrwViewNodeDef As NativeBrowserNodeDefinition
        Set oDrwViewNodeDef = oDrwDoc.BrowserPanes.GetNativeBrowserNodeDefinition(oDrwView)
   
        Dim oTopNode As BrowserNode
        Set oTopNode = oDrwDoc.BrowserPanes.ActivePane.TopNode
     
        Dim oBrowserNodesEnum As BrowserNodesEnumerator
        Set oBrowserNodesEnum = oTopNode.AllReferencedNodes(oDrwViewNodeDef)
     
        Dim oBrowserNode As Inventor.BrowserNode
        Dim oBrowserFolders As BrowserFoldersEnumerator
         
        Set oBrowserFolders = oBrowserNodesEnum.Item(1).BrowserNodes.Item(1).BrowserFolders
        Dim oBrowserFolder As BrowserFolder
       
   
            For Each oBrowserFolder In oBrowserFolders
                If oBrowserFolder.name = "Normteile" Then 'Ordnername anpassen
                    For Each oBrowserNode In oBrowserFolder.BrowserNode.BrowserNodes
                       
                        oBrowserNode.Expanded = True
                        Call oBrowserNode.DoSelect
                        Call oApp.CommandManager.ControlDefinitions.Item("SelectAsEdgesCtxCmd").Execute 'Hier bekommst du alle Kanten auf einmal
                     
                        'MsgBox oDrwDoc.SelectSet.Count 'Zur Kontrolle ob SelectSte befüllt wurde
                   
                        Dim oCurSegment As DrawingCurveSegment
                        For Each oCurSegment In oDrwDoc.SelectSet
                            'oCurSegment.Layer = WunschLayer 'Leg dein CurveSegment auf ein Layer
                            oCurSegment.Visible = False 'Mach irgendwas anderes mit den Kurvensegmenten
                        Next
                     
                    Next
                End If
            Next
    Next
   
    oTrans.End
   
    Call oApp.CommandManager.ControlDefinitions.Item("AppBrowserCollapseAllCmd").Execute
   
   
    Call oDrwDoc.Update2(True)

End Sub

---

Allerdings natürlich ohne die schöne ausschweifende Rekursion und ausgiebige Fehlerbehandlung von dir. 

Grüße

EIBe 3D

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

---

Wow, Ralf und ElBe 3D, ihr seit grossartig Vielen herzlichen Dank, damit kann ich definitiv arbeiten und auf meine Gegebenheiten anpassen.

Ich wünsche euch einen guten Start in die frische Woche.

Beste Grüsse
Raphael

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

---

Wie ich im Code von Ralf Code gesehen habe, bricht die Routine ab, wenn die Ansicht ein Schnitt ist. Aber das wegen möglichen fehlenden Kanten.
Wenn ich den Code von ElBe 3d teste, funktioniert alles, ausser ich habe eine Schnittansicht. Dann bekomme ich eine Fehlermeldung "Die Methode 'GetNativeBrowserNodeDefinition' für das Objekt 'BrowserPanes' ist fehlgeschlagen.
Kann das irgendwie abgefangen werden?

Edit: Auch werden die Layer der Erstansicht nicht angepasst und bleiben auf dem Normlayer. Muss die Erstansicht diesbezüglich gesondert behandelt werden?

[Diese Nachricht wurde von OibelTroibel am 12. Apr. 2021 editiert.]

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

---

Hallo

Schnittansichten kannste vergessen. Was ich da schon an grauen Haaren bekommen habe. 

Du könntest das DrawingView.ViewType Property prüfen. Wenn es ein kSectionDrawingViewType ist, hast du eine Schnittansicht.

Bei wem kommt das mit der Erstansicht? Das verstehe ich gerade nicht.

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

RKW Solutions GmbH
www.RKW-Solutions.com

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

---

Zitat:

---

... Bei wem kommt das mit der Erstansicht? Das verstehe ich gerade nicht.

---

Der Fehler tritt bei mir auf. Scheinbar wenn eine Schnittansicht am der (Erst-) Ansicht hängt. Dann schlägt die Methode bereits für die übergeordnete Ansichtr fehl. Selbiges bei einer Detailansicht.

Bei einer Hilfsansicht läuft die Methode interesanterweise durch, behandelt aber nur die Hilfsansicht.

Einfache Lösung für den Moment:
Ralfs Programm nutzen 

Grüße

EIBe 3D

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

---

Genau, das Problem mit der Erstansicht habe ich mit dem Code von ElBe 3D. Aber Anscheinend ist das ein generelles Problem mit Schnittansichten, was in meinem Fall sehr schade ist, da es fast ausschliesslich um Layeränderungen in Schnittansichten geht   Zum jetzigen Zeitpunkt hätte ich natürlich gut dran getan, dies bereits im Eingangspost zu erwähnen.

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

---

So wie ich Ralfs Kommentarzeile verstehe:

Code:

---

Private Function CheckDrawView(ByVal oDrawView As DrawingView) As Boolean
    'Vorprüfungen einer Zeichgnungsansicht
 
    ...

    'In Schnittansichten fehlen immer wieder nicht reproduzierbar Kanten
    If oDrawView.ViewType = DrawingViewTypeEnum.kSectionDrawingViewType Then CheckDrawView = False
...

---

geht es prinzipiell, bereitet aber häufiger wohl mal Schwierigkeiten.

Habe entsprechende Zeile mal auskommentiert und getestet -> hat geklappt, war aber ein sehr einfacher Schnitt mit wenig Bauteilen.

Kannst ja auf eigene Gefahr die Zeile auskommentieren und schauen wie lange es gut geht.

Nur: Ich habe niemanden verleitet!

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

---

Hallo

Zitat:

---

dies bereits im Eingangspost zu erwähnen.

---

Dann hättest du vorher alles selbst gewußt und nicht fragen müssen. 

Man kann Schnittansichten versuchen, aber ich hatte unter anderem:
- Kanten die man auf dem Blatt sehen konnte, aber die in der API nicht existierten
- Kanten die statt DrawingCurve oder DrawingCurveSegment angeblich GenericObject sind
- Kanten die nicht zum Schnitt gehören, wurden sichtbar

Das war einfach nicht stabil und wenn man sich drauf verlassen will/muss, dass die Farben stimmen bringt das nix.

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

RKW Solutions GmbH
www.RKW-Solutions.com

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

---

Zitat:

---

Kannst ja auf eigene Gefahr die Zeile auskommentieren und schauen wie lange es gut geht.

---

Habe das mal gemacht und bete

Zitat:

---

Dann hättest du vorher alles selbst gewußt und nicht fragen müssen.

---

Hast auch wieder recht vielen Dank für deine Nachsicht

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

---

Edit: Habe einen neuen Thread eröffnet, da bereits als gelöst markiert und das Problem nicht genau das selbe ist

[Diese Nachricht wurde von OibelTroibel am 15. Nov. 2023 editiert.]

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

---

Moin

Nicht hetzen und kein neues Thema eröffnen bitte.

Sollte beide Anforderungen erfüllen. Ohne Beispieldateien immer schwer zu testen.

Code:

---

Option Explicit

Private Sub SwitchLayerByFolder()

    Dim oDrawDoc As DrawingDocument
    Set oDrawDoc = ThisApplication.ActiveDocument
 
    Dim oDrawView As DrawingView
    Set oDrawView = ThisApplication.CommandManager.Pick(kDrawingViewFilter, "Anicht auswählen")
 
    If CheckDrawView(oDrawView) = False Then
        Exit Sub
    End If
 
    Call ResetLayers(oDrawView)
 
    Dim oAssDoc As AssemblyDocument
    Set oAssDoc = oDrawView.ReferencedDocumentDescriptor.ReferencedDocument
 
    Dim oBrowserPane As BrowserPane
    Set oBrowserPane = oAssDoc.BrowserPanes.Item("AmBrowserArrangement")
 
    Dim oTopNode As BrowserNode
    Set oTopNode = oBrowserPane.TopNode
 
    Dim oFolder As BrowserFolder
    For Each oFolder In oTopNode.BrowserFolders
        Call TraverseBrowserFolder(oAssDoc, oDrawView, oFolder)
    Next
 
    Call TraverseBrowserNodes(oAssDoc, oDrawView, oTopNode)
 
    MsgBox ("Done")

End Sub
 
Private Sub TraverseBrowserNodes(ByVal oAssDoc As AssemblyDocument, ByVal oDrawView As DrawingView, ByVal oBrowserNode As BrowserNode)
 
    Dim oFolder As Inventor.BrowserFolder
    Dim oNode As Inventor.BrowserNode
    For Each oNode In oBrowserNode.BrowserNodes
        'wir interessieren uns derzeit nur für BrowserNodes in BrowserFoldern
        ' "normale" Nodes ignorieren wir einfach
        'Call ProcessBrowserNode(oNode)
        If Not oNode.NativeObject Is Nothing And oNode.Visible = True Then
            If oNode.NativeObject.Type = kAssemblyComponentDefinitionObject Then
                Call TraverseBrowserNodes(oAssDoc, oDrawView, oNode)
            End If
        End If
       
        For Each oFolder In oNode.BrowserFolders
            Call TraverseBrowserFolder(oAssDoc, oDrawView, oFolder)
        Next
     
        Call TraverseBrowserNodes(oAssDoc, oDrawView, oNode)
    Next
 
End Sub

Private Sub TraverseBrowserFolder(ByVal oAssDoc As AssemblyDocument, ByVal oDrawView As DrawingView, ByVal oBrowserFolder As BrowserFolder)
 
    Dim sName As String
    Dim oNode As BrowserNode
    Dim oBrowserNode As BrowserNode
    Set oBrowserNode = oBrowserFolder.BrowserNode
 
    Dim oObj As Object
    For Each oNode In oBrowserNode.BrowserNodes
        Set oObj = GetBrowserFolderItem(oNode)
        If Not oObj Is Nothing Then
            'If oObj.DefinitionDocumentType = kPartDocumentObject Then '<-- aktivieren, um nur Bauteile zu berücksichtigen
                Dim oDrawCurves As DrawingCurvesEnumerator
                Set oDrawCurves = oDrawView.DrawingCurves(oObj)
                If Not oDrawCurves Is Nothing Then
                    Dim oLayer As Layer
                    Set oLayer = GetLayer(oDrawView, oBrowserFolder.Name)  '<--FolderName als Layername? Notfalls neu erstellen?
                 
                    Dim oDrawCurveSegmentsColl As ObjectCollection
                    Set oDrawCurveSegmentsColl = ThisApplication.TransientObjects.CreateObjectCollection
                 
                    Dim oDrawCurve As DrawingCurve
                    Dim oDrawCurveSegment As DrawingCurveSegment
                    For Each oDrawCurve In oDrawCurves
                        For Each oDrawCurveSegment In oDrawCurve.Segments
                            If oDrawCurveSegment.Visible = True Then
                                If oDrawCurveSegment.HiddenLine = False Then
                                    Call oDrawCurveSegmentsColl.Add(oDrawCurveSegment)
                                End If
                            End If
                        Next
                    Next
                    Call oDrawView.Parent.ChangeLayer(oDrawCurveSegmentsColl, oLayer)
                    Set oDrawCurves = Nothing
                End If
            'End If
        End If
        Set oObj = Nothing
    Next
 
    Dim oFolder As Inventor.BrowserFolder
    For Each oFolder In oBrowserNode.BrowserFolders
        Call TraverseBrowserFolder(oAssDoc, oDrawView, oFolder)
    Next
     
End Sub

Private Function GetBrowserFolderItem(ByVal oBrowserNode As BrowserNode) As Object
 
    Select Case oBrowserNode.NativeObject.Type
        Case kComponentOccurrenceObject:
                Set GetBrowserFolderItem = oBrowserNode.NativeObject
        Case kRectangularOccurrencePatternObject:
                Set GetBrowserFolderItem = oBrowserNode.NativeObject
        Case kCircularOccurrencePatternObject:
                Set GetBrowserFolderItem = oBrowserNode.NativeObject
        Case kComponentOccurrenceProxyObject:
                Set GetBrowserFolderItem = oBrowserNode.NativeObject
        Case kRectangularOccurrencePatternProxyObject:
                Set GetBrowserFolderItem = oBrowserNode.NativeObject
        Case kCircularOccurrencePatternProxyObject:
                Set GetBrowserFolderItem = oBrowserNode.NativeObject
        Case kBrowserFolderObject:
                'nix machen
        Case Else:
                MsgBox ("unknown")
    End Select
 
End Function

Private Function GetLayer(ByVal oDrawView As DrawingView, ByVal sFolderName As String) As Layer
 
    Dim oDrawDoc As DrawingDocument
    Set oDrawDoc = oDrawView.Parent.Parent
 
    On Error Resume Next
    Set GetLayer = oDrawDoc.StylesManager.Layers.Item(sFolderName)
    On Error GoTo 0
    If GetLayer Is Nothing Then
        Set GetLayer = CreateLayer(oDrawDoc, sFolderName, kContinuousLineType, 255, 0, 0)
    End If
 
End Function

Private Function CreateLayer(ByVal oDrawDoc As DrawingDocument, ByVal sLayerName As String, ByVal eLineType As Inventor.LineTypeEnum, ByVal iRed As Integer, ByVal iGreen As Integer, ByVal iBlue As Integer) As Layer

    Dim oStylesManager As DrawingStylesManager
    Set oStylesManager = oDrawDoc.StylesManager

    Dim oColor As Inventor.Color
    Set oColor = ThisApplication.TransientObjects.CreateColor(CByte(iRed), CByte(iGreen), CByte(iBlue))

    Dim oLayer As Layer
    Set oLayer = oStylesManager.Layers.Item(1).Copy(sLayerName)
    With oLayer
        .LineType = eLineType
        .Color = oColor
        .LineWeight = 0.05
        .ScaleByLineWeight = True
    End With
 
    Set CreateLayer = oLayer

End Function

Private Function CheckDrawView(ByVal oDrawView As DrawingView) As Boolean
    'Vorprüfungen einer Zeichgnungsansicht
 
    'Ansicht iO
    CheckDrawView = True
 
    'oder doch nicht?
 
    'Ist die Ansicht unterdrückt?
    If oDrawView.Suppressed = True Then CheckDrawView = False
 
    'gerasterte Ansicht kann man eh nicht
    If oDrawView.IsRasterView = True Then CheckDrawView = False

    'Entwurfsansichten haben kein assoziiertes 3D-Modell
    If oDrawView.ViewType = DrawingViewTypeEnum.kDraftDrawingViewType Then CheckDrawView = False

    'In Schnittansichten fehlen immer wieder nicht reproduzierbar Kanten
    If oDrawView.ViewType = DrawingViewTypeEnum.kSectionDrawingViewType Then CheckDrawView = False

    'Ist das 3D-Modell aktuell oder stehen Aktualisierung aus?
    Dim oDoc As Document
    Set oDoc = oDrawView.ReferencedDocumentDescriptor.ReferencedDocument
 
    If Not oDoc.DocumentType = kAssemblyDocumentObject Then
        Call MsgBox("Die Ansicht muss eine Baugruppe referenzieren.", vbCritical)
        CheckDrawView = False
        Return
    End If
     
     
    If oDoc.RequiresUpdate = True Then
        If MsgBox("Das Modell muss aktualisiert werden. Aktualisieren und fortfahren?", vbYesNo) = vbNo Then
            CheckDrawView = False
        End If
        Call oDoc.Update
    End If

End Function

Private Sub ResetLayers(ByVal oDrawView As DrawingView)

    Dim oDrawCurveSegmentsColl As ObjectCollection
    Set oDrawCurveSegmentsColl = ThisApplication.TransientObjects.CreateObjectCollection
 
    Dim oDrawCurve As DrawingCurve
    Dim oDrawCurveSegment As DrawingCurveSegment
 
    For Each oDrawCurve In oDrawView.DrawingCurves
        oDrawCurve.OverrideColor = Nothing
        For Each oDrawCurveSegment In oDrawCurve.Segments
            If oDrawCurveSegment.Visible = True Then
                If oDrawCurveSegment.HiddenLine = False Then
                    Call oDrawCurveSegmentsColl.Add(oDrawCurveSegment)
                End If
            End If
        Next
    Next
 
    Dim oLayer As Layer
    Call oDrawView.Parent.ChangeLayer(oDrawCurveSegmentsColl, oLayer)
 
End Sub

---

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

RKW Solutions GmbH
www.RKW-Solutions.com

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

---

Hallo Ralf

Erst einmal herzlichen Dank, dass du dir nochmals Zeit nimmst mir zu helfen   Und sorry fürs eröffnen des neuen Threads, ich dachte es wird so übersichtlicher.
Ich habe deine Anpassungen bei mir übernommen, leider erhalte ich bei

Code:

---

If Not oNode.NativeObject Is Nothing And oNode.Visible = True Then

---

die Fehlermeldung Laufzeitfehler '-2147467259 (80004005)': Die Methode 'NativeObject' für das Objekt 'BrowserNode' ist fehlgeschlagen und ich kann nichts mit dieser Meldung anfangen.
Der Wert von oNode.NativeObjekt ist zum Fehlerzeitpunkt <Anwendungs- oder objektdefinierter Fehler> . Weist du weiter? Du weist   , aber hilfst du mir weiter  

[Diese Nachricht wurde von OibelTroibel am 16. Nov. 2023 editiert.]

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

---

Layerbaugruppe.rar.txt

Ich habe mal eine einfache Beispielbaugruppe erstellt für die bessere Übersicht

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

---

Moin

Die Meldung kommt, wenn der Browserknoten gar kein Nativeobject hat. Wußte nicht, das es das gibt. Das NativeObject kann das Bauteil- oder Baugruppenexemplar sein, das der Knoten im Baum darstellt. Ich war davon ausgegangen, das im schlimmsten Fall dieses Objekt leer ist. Versuch es mal bitte mit dieser erweiterten Sub. Einfach im vorhandenen Code ersetzen.

Code:

---

Private Sub TraverseBrowserNodes(ByVal oAssDoc As AssemblyDocument, ByVal oDrawView As DrawingView, ByVal oBrowserNode As BrowserNode)

    Dim oFolder As Inventor.BrowserFolder
    Dim oNode As Inventor.BrowserNode
    For Each oNode In oBrowserNode.BrowserNodes
        'wir interessieren uns derzeit nur für BrowserNodes in BrowserFoldern
        ' "normale" Nodes ignorieren wir einfach
        'Call ProcessBrowserNode(oNode)
       
        Dim oObj As Object
        On Error Resume Next
        Set oObj = oNode.NativeObject
        If Err.Number = 0 Then
            If Not oObj Is Nothing And oNode.Visible = True Then
                If oNode.NativeObject.Type = kAssemblyComponentDefinitionObject Then
                    Call TraverseBrowserNodes(oAssDoc, oDrawView, oNode)
                End If
            End If
        End If
               
        On Error GoTo 0
       
        For Each oFolder In oNode.BrowserFolders
            Call TraverseBrowserFolder(oAssDoc, oDrawView, oFolder)
        Next
   
        Call TraverseBrowserNodes(oAssDoc, oDrawView, oNode)
    Next

End Sub

---

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

RKW Solutions GmbH
www.RKW-Solutions.com

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

---

Perfekt, du hast es drauf Herzlichen Dank, genau so sollte es sein

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

---

Da ist noch eine Sache und zwar überspringt er Komponentenanordnungen innerhalb der Ordner. So wie ich gesehen habe, könnte ich das eine Private Sub wie folgt anpassen:

Code:

---

Private Sub TraverseBrowserNodes(ByVal oAssDoc As AssemblyDocument, ByVal oDrawView As DrawingView, ByVal oBrowserNode As BrowserNode)

    Dim oFolder As Inventor.BrowserFolder
    Dim oNode As Inventor.BrowserNode
    For Each oNode In oBrowserNode.BrowserNodes
        'wir interessieren uns derzeit nur für BrowserNodes in BrowserFoldern
        ' "normale" Nodes ignorieren wir einfach
        'Call ProcessBrowserNode(oNode)
     
        Dim oObj As Object
        On Error Resume Next
        Set oObj = oNode.NativeObject
        If Err.Number = 0 Then
            If Not oObj Is Nothing And oNode.Visible = True Then
                If oNode.NativeObject.Type = kAssemblyComponentDefinitionObject Then
                    Call TraverseBrowserNodes(oAssDoc, oDrawView, oNode)
                ElseIf oNode.Expanded = True Then
                    Call TraverseBrowserNodes(oAssDoc, oDrawView, oNode)
                End If
            End If
        End If
             
        On Error GoTo 0
     
        For Each oFolder In oNode.BrowserFolders
            Call TraverseBrowserFolder(oAssDoc, oDrawView, oFolder)
        Next
 
        Call TraverseBrowserNodes(oAssDoc, oDrawView, oNode)
    Next

End Sub

---

Nur habe ich dann nicht mehr den direkten Bezug zum Ordnernamen, den ich abrufen möchte. Wie kann man das einfach lösen? Sorry für meine ständigen Fragen

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

---

Moin

oNode.Expanded signalisiert ob der Browserknoten ausgeklappt ist. Wenn nicht augeklappt, ignoriert er die Anordnung im Ordner genauso.
Ich werd das heute nicht mehr schaffen, da ich über's WE auf Schulung bin. Muss ich mir Montag ansehen. Nur kurz den vermuteten Weg skizziert:
Es gilt zu prüfen, ob das NativeObject des Knotens ein RectangularPattern oder CircularPattern ist. Wenn ja, in einer Schleife durch die PatternElements und sich deren Typ ansehen. Es könnten Bauteile, Baugruppen oder wiederum Muster/Anordnungen sein. Da werden noch zwei Rekursion nötig, um da bis unten abzutauchen.

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

RKW Solutions GmbH
www.RKW-Solutions.com

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

---

Ich möchte dich nicht hetzen und es ist auch nicht super dringend Da war ich wohl bereits auf dem Holzweg - ich dachte Expand bezieht sich auf einen "Unterordner" der sich aufklappen lässt   Aber anscheinend hatte ich beim testen einfach den Anordnungsordner offen.
Ich versuche derweil selbst noch etwas und hoffe noch etwas zu lernen
Ich wünsche dir ein schönes Wochenende

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

---

Sorry, versehentlich aktualisiert und nochmals gepostet

[Diese Nachricht wurde von OibelTroibel am 17. Nov. 2023 editiert.]

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

---

Moin

Next try:

Code:

---

Option Explicit

Public Sub SwitchLayerByFolder()

    Dim oDrawDoc As DrawingDocument
    Set oDrawDoc = ThisApplication.ActiveDocument

    Dim oDrawView As DrawingView
    Set oDrawView = ThisApplication.CommandManager.Pick(kDrawingViewFilter, "Anicht auswählen")

    If CheckDrawView(oDrawView) = False Then
        Exit Sub
    End If

    Call ResetLayers(oDrawView)

    Dim oAssDoc As AssemblyDocument
    Set oAssDoc = oDrawView.ReferencedDocumentDescriptor.ReferencedDocument

    Dim oBrowserPane As BrowserPane
    Set oBrowserPane = oAssDoc.BrowserPanes.Item("AmBrowserArrangement")

    Dim oTopNode As BrowserNode
    Set oTopNode = oBrowserPane.TopNode

    Dim oFolder As BrowserFolder
    For Each oFolder In oTopNode.BrowserFolders
        Call TraverseBrowserFolder(oAssDoc, oDrawView, oFolder)
    Next

    Call TraverseBrowserNodes(oAssDoc, oDrawView, oTopNode)

    MsgBox ("Done")

End Sub

Private Sub TraverseBrowserNodes(ByVal oAssDoc As AssemblyDocument, ByVal oDrawView As DrawingView, ByVal oBrowserNode As BrowserNode)

    Dim oFolder As Inventor.BrowserFolder
    Dim oNode As Inventor.BrowserNode
    For Each oNode In oBrowserNode.BrowserNodes
        'wir interessieren uns derzeit nur für BrowserNodes in BrowserFoldern
        ' "normale" Nodes ignorieren wir einfach
        'Call ProcessBrowserNode(oNode)
     
        Dim oObj As Object
        On Error Resume Next
        Set oObj = oNode.NativeObject
        If Err.Number = 0 Then
            If Not oObj Is Nothing And oNode.Visible = True Then
                If oNode.NativeObject.Type = kAssemblyComponentDefinitionObject Then
                    Call TraverseBrowserNodes(oAssDoc, oDrawView, oNode)
                End If
            End If
        End If
             
        On Error GoTo 0
     
        For Each oFolder In oNode.BrowserFolders
            Call TraverseBrowserFolder(oAssDoc, oDrawView, oFolder)
        Next
 
        'Call TraverseBrowserNodes(oAssDoc, oDrawView, oNode)
    Next

End Sub

Private Sub TraverseBrowserFolder(ByVal oAssDoc As AssemblyDocument, ByVal oDrawView As DrawingView, ByVal oBrowserFolder As BrowserFolder)

    Dim sName As String
    Dim oNode As BrowserNode
    Dim oBrowserNode As BrowserNode
    Set oBrowserNode = oBrowserFolder.BrowserNode

    Dim oObj As Object
    Dim oOccPatternElements As OccurrencePatternElements
   
    For Each oNode In oBrowserNode.BrowserNodes
        Set oObj = GetBrowserFolderItem(oNode)
        If Not oObj Is Nothing Then
            If oObj.Type = kRectangularOccurrencePatternProxyObject Then
                Set oOccPatternElements = oObj.OccurrencePatternElements 'oObj.NativeObject.OccurrencePatternElements
                Call TraversePatternElements(oOccPatternElements, oDrawView, oBrowserFolder)
            ElseIf oObj.Type = kCircularOccurrencePatternProxyObject Then
                Set oOccPatternElements = oObj.OccurrencePatternElements
                Call TraversePatternElements(oOccPatternElements, oDrawView, oBrowserFolder)
            ElseIf oObj.Type = kRectangularOccurrencePatternObject Then
                Set oOccPatternElements = oObj.OccurrencePatternElements
                Call TraversePatternElements(oOccPatternElements, oDrawView, oBrowserFolder)
            ElseIf oObj.Type = kCircularOccurrencePatternObject Then
                Set oOccPatternElements = oObj.OccurrencePatternElements
                Call TraversePatternElements(oOccPatternElements, oDrawView, oBrowserFolder)
            Else
                Call ProcessObject(oObj, oDrawView, oBrowserFolder)
            End If
        End If
        Set oObj = Nothing
    Next

    Dim oFolder As Inventor.BrowserFolder
    For Each oFolder In oBrowserNode.BrowserFolders
        Call TraverseBrowserFolder(oAssDoc, oDrawView, oFolder)
    Next
   
End Sub

Private Sub TraversePatternElements(ByVal oPatternElements As OccurrencePatternElements, ByVal oDrawView As DrawingView, ByVal oBrowserFolder As BrowserFolder)
    Dim oPatternElement As OccurrencePatternElement
    Dim oOcc As ComponentOccurrence
    For Each oPatternElement In oPatternElements
        For Each oOcc In oPatternElement.Occurrences
            If oOcc.DefinitionDocumentType = kAssemblyDocumentObject Then
                Call ProcessOccs(oOcc.SubOccurrences, oDrawView, oBrowserFolder)
            ElseIf oOcc.DefinitionDocumentType = kPartDocumentObject Then
                Call ProcessObject(oOcc, oDrawView, oBrowserFolder)
            End If
        Next
    Next

End Sub

Private Sub ProcessOccs(ByVal oOccs As ComponentOccurrences, ByVal oDrawView As DrawingView, ByVal oBrowserFolder As BrowserFolder)
    Dim oOcc As ComponentOccurrence
    For Each oOcc In oOccs
        If oOcc.SubOccurrences.count > 0 Then
            Call ProcessOccs(oOcc.SubOccurrences, oDrawView, oBrowserFolder)
        End If
       
        Call ProcessObject(oOcc, oDrawView, oBrowserFolder)
    Next

End Sub

Private Sub ProcessObject(ByVal oObj As Object, ByVal oDrawView As DrawingView, ByVal oBrowserFolder As BrowserFolder)

    'If oObj.DefinitionDocumentType = kPartDocumentObject Then '<-- aktivieren, um nur Bauteile zu berücksichtigen
        Dim oDrawCurves As DrawingCurvesEnumerator
        Set oDrawCurves = oDrawView.DrawingCurves(oObj)
        If Not oDrawCurves Is Nothing Then
            Dim oLayer As Layer
            Set oLayer = GetLayer(oDrawView, oBrowserFolder.Name)  '<--FolderName als Layername? Notfalls neu erstellen?
               
            Dim oDrawCurveSegmentsColl As ObjectCollection
            Set oDrawCurveSegmentsColl = ThisApplication.TransientObjects.CreateObjectCollection
               
            Dim oDrawCurve As DrawingCurve
            Dim oDrawCurveSegment As DrawingCurveSegment
            For Each oDrawCurve In oDrawCurves
                For Each oDrawCurveSegment In oDrawCurve.Segments
                    If oDrawCurveSegment.Visible = True Then
                        If oDrawCurveSegment.HiddenLine = False Then
                            Call oDrawCurveSegmentsColl.Add(oDrawCurveSegment)
                        End If
                    End If
                Next
            Next
            Call oDrawView.Parent.ChangeLayer(oDrawCurveSegmentsColl, oLayer)
            Set oDrawCurves = Nothing
        End If
    'End If

End Sub

Private Function GetBrowserFolderItem(ByVal oBrowserNode As BrowserNode) As Object

    Select Case oBrowserNode.NativeObject.Type
        Case kComponentOccurrenceObject:
                Set GetBrowserFolderItem = oBrowserNode.NativeObject
        Case kRectangularOccurrencePatternObject:
                Set GetBrowserFolderItem = oBrowserNode.NativeObject
        Case kCircularOccurrencePatternObject:
                Set GetBrowserFolderItem = oBrowserNode.NativeObject
        Case kComponentOccurrenceProxyObject:
                Set GetBrowserFolderItem = oBrowserNode.NativeObject
        Case kRectangularOccurrencePatternProxyObject:
                Set GetBrowserFolderItem = oBrowserNode.NativeObject
        Case kCircularOccurrencePatternProxyObject:
                Set GetBrowserFolderItem = oBrowserNode.NativeObject
        Case kBrowserFolderObject:
                'nix machen
        Case Else:
                MsgBox ("unknown")
    End Select

End Function

Private Function GetLayer(ByVal oDrawView As DrawingView, ByVal sFolderName As String) As Layer

    Dim oDrawDoc As DrawingDocument
    Set oDrawDoc = oDrawView.Parent.Parent

    On Error Resume Next
    Set GetLayer = oDrawDoc.StylesManager.Layers.Item(sFolderName)
    On Error GoTo 0
    If GetLayer Is Nothing Then
        Set GetLayer = CreateLayer(oDrawDoc, sFolderName, kContinuousLineType, 255, 0, 0)
    End If

End Function

Private Function CreateLayer(ByVal oDrawDoc As DrawingDocument, ByVal sLayerName As String, ByVal eLineType As Inventor.LineTypeEnum, ByVal iRed As Integer, ByVal iGreen As Integer, ByVal iBlue As Integer) As Layer

    Dim oStylesManager As DrawingStylesManager
    Set oStylesManager = oDrawDoc.StylesManager

    Dim oColor As Inventor.Color
    Set oColor = ThisApplication.TransientObjects.CreateColor(CByte(iRed), CByte(iGreen), CByte(iBlue))

    Dim oLayer As Layer
    Set oLayer = oStylesManager.Layers.Item(1).Copy(sLayerName)
    With oLayer
        .LineType = eLineType
        .Color = oColor
        .LineWeight = 0.05
        .ScaleByLineWeight = True
    End With

    Set CreateLayer = oLayer

End Function

Private Function CheckDrawView(ByVal oDrawView As DrawingView) As Boolean
    'Vorprüfungen einer Zeichgnungsansicht

    'Ansicht iO
    CheckDrawView = True

    'oder doch nicht?

    'Ist die Ansicht unterdrückt?
    If oDrawView.Suppressed = True Then CheckDrawView = False

    'gerasterte Ansicht kann man eh nicht
    If oDrawView.IsRasterView = True Then CheckDrawView = False

    'Entwurfsansichten haben kein assoziiertes 3D-Modell
    If oDrawView.ViewType = DrawingViewTypeEnum.kDraftDrawingViewType Then CheckDrawView = False

    'In Schnittansichten fehlen immer wieder nicht reproduzierbar Kanten
    If oDrawView.ViewType = DrawingViewTypeEnum.kSectionDrawingViewType Then CheckDrawView = False

    'Ist das 3D-Modell aktuell oder stehen Aktualisierung aus?
    Dim oDoc As Document
    Set oDoc = oDrawView.ReferencedDocumentDescriptor.ReferencedDocument

    If Not oDoc.DocumentType = kAssemblyDocumentObject Then
        Call MsgBox("Die Ansicht muss eine Baugruppe referenzieren.", vbCritical)
        CheckDrawView = False
        Return
    End If
   
   
    If oDoc.RequiresUpdate = True Then
        If MsgBox("Das Modell muss aktualisiert werden. Aktualisieren und fortfahren?", vbYesNo) = vbNo Then
            CheckDrawView = False
        End If
        Call oDoc.Update
    End If

End Function

Private Sub ResetLayers(ByVal oDrawView As DrawingView)

    Dim oDrawCurveSegmentsColl As ObjectCollection
    Set oDrawCurveSegmentsColl = ThisApplication.TransientObjects.CreateObjectCollection

    Dim oDrawCurve As DrawingCurve
    Dim oDrawCurveSegment As DrawingCurveSegment

    For Each oDrawCurve In oDrawView.DrawingCurves
        oDrawCurve.OverrideColor = Nothing
        For Each oDrawCurveSegment In oDrawCurve.Segments
            If oDrawCurveSegment.Visible = True Then
                If oDrawCurveSegment.HiddenLine = False Then
                    Call oDrawCurveSegmentsColl.Add(oDrawCurveSegment)
                End If
            End If
        Next
    Next

    Dim oLayer As Layer
    Call oDrawView.Parent.ChangeLayer(oDrawCurveSegmentsColl, oLayer)

End Sub

---

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

RKW Solutions GmbH
www.RKW-Solutions.com

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

---

Woooooow, herzlichen Dank Ralf, einfach genial. Wann bist du das nächste Mal in der Schweiz?

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

---

Moin

Keine Ahnung ob ich da jemals vorbeikomme. Freut mich das es läuft. 
Wie lange braucht das Skript so für eine Durchlauf? In meiner Testbaugruppe sind ja nur eine handvoll Teile drin. Bei den ganzen Rekursionen könnte ich mir vorstellen, dass es mit zunehmender Teileanzahl zäh wird.

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

RKW Solutions GmbH
www.RKW-Solutions.com

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

---

Bei grossen Baugruppen und mehreren Seiten kann es schon bis 30 min dauern. Aber das kann man sich so legen, dass es nicht weiter schlimm ist. Dafür entfällt viel Handarbeit

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

---

Moin

30 Minuten ist schon heftig. Wenn ich mal Zeit habe, überleg ich mal ob man die Rekursionen besser vermeiden kann.

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

RKW Solutions GmbH
www.RKW-Solutions.com

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

---

Das wäre natürlich toll, aber mach dir deswegen keinen Stress. Es macht was es soll und wenn man es weiss, kann man das Ausführen so legen, dass es einem nicht stört.
Was mir nun aber noch aufgefallen ist - hat aber nichts mit deinem Script zu tun - es gibt Kanten die extrem lange brauchen um zu berechnen. Auch wenn ich die Bauteile als Kanten auswählen möchte, benötigt Inventor sehr lange. Habe aber noch nicht erkannt, was genau das Problem ist. Sind Splines generell länger zu berechnen oder gibt es spezielle Kanten die sehr rechenintensiv sind? An sich ist das Bauteil nicht sehr komplex, ist einfach ein gedrücktes Blechbauteil.

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