Jetzt habe ich den Code wieder gefunden. Im Moment habe ich allerdings keine Zeit es zu testen.
Was meint die kundige Gemeinde? Könnte das klappen? Der Code wurde für eine *.idw geschrieben, ich möchte es für *.dwg verwenden.
In dem Thread wurde dann nicht weiter darauf eingegangen, ob der Code funktioniert hat.
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
Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP