Guten Morgen zusammen,
ich habe mir vor längerer Zeit mal folgendes Makro zusammenkopiert bzw. angepasst. Mit diesem Makro wird abhängig von der Bauteilfarbe auf der Zeichnung die Linien / Layer angepasst. Leider funktioniert es nur bei Zeichnungen die von Baugruppen abhängig sind. Schön währe es würde für alle Zeichnungen egal von welcher Inventordatei diese abstammen.
Ich habe schon versucht es umzuhebeln - bisher erfolglos - nun meine Frage hat jemand lust und Zeit mir hierbei zuhelfen? Ich würde mich sehr freuen (-:
Public Sub RefDarstellung()
' Aktives Dokument auswählen
Dim drawDoc As DrawingDocument
Set drawDoc = ThisApplication.ActiveDocument
Dim drawView As DrawingView
For Each drawView In drawDoc.ActiveSheet.DrawingViews
Dim docDesc As DocumentDescriptor
Set docDesc = drawView.ReferencedDocumentDescriptor
' Checken das die selectierte Drawing View von einer Baugruppe ist
If docDesc.ReferencedDocumentType <> kAssemblyDocumentObject Then
MsgBox "Die Zeichnung muss von einer Baugruppe abstammen!"
Exit Sub
End If
' Get the component definition for the assembly.
Dim asmDef As AssemblyComponentDefinition
Set asmDef = docDesc.ReferencedDocument.ComponentDefinition
' Process the occurrences, wrapping it in a transaction so the
' entire process can be undone with a single undo operation.
Dim trans As Transaction
Set trans = ThisApplication.TransactionManager.StartTransaction(drawDoc, "Change drawing view Layer")
' Call the recursive function that does all the work.
Call ProcessAssemblyColor(drawView, asmDef.Occurrences)
trans.End
Next
MsgBox "Layer wurden zur Referenzansicht angepasst!!"
End Sub
Private Sub ProcessAssemblyColor(drawView As DrawingView, Occurrences As ComponentOccurrences)
' Iterate through the current collection of occurrences.
Dim occ As ComponentOccurrence
Dim sLayer As String
For Each occ In Occurrences
' Check to see if this occurrence is a part or assembly.
If occ.DefinitionDocumentType = kPartDocumentObject Then
' ** It's a part so process the BOM structure´
sLayer = ""
' Get the render style of the occurrence.
Dim color As RenderStyle
Dim sourceType As StyleSourceTypeEnum
Set color = occ.GetRenderStyle(sourceType)
Select Case color.Name
Case "Ansicht Referenz 1": sLayer = "Ansicht Referenz 1"
Case "Ansicht Referenz 2": sLayer = "Ansicht Referenz 2"
Case "Ansicht Referenz 3": sLayer = "Ansicht Referenz 3"
End Select
If sLayer <> "" Then
' Get the TransientsObjects object to use later.
Dim transObjs As TransientObjects
Set transObjs = ThisApplication.TransientObjects
' Verify that the layers Referenz exist
Dim layers As LayersEnumerator
Set layers = drawView.Parent.Parent.StylesManager.layers
Dim drawDoc As DrawingDocument
Set drawDoc = drawView.Parent.Parent
On Error Resume Next
Dim oLayer As Layer
Set oLayer = layers.Item(sLayer)
If Not oLayer Is Nothing Then
' Get all of the curves associated with this occurrence.
On Error Resume Next
Dim drawcurves As DrawingCurvesEnumerator
Set drawcurves = drawView.DrawingCurves(occ)
If Err.Number = 0 Then
On Error GoTo 0
' Create an empty collection.
Dim objColl As ObjectCollection
Set objColl = transObjs.CreateObjectCollection()
' Add the curve segments to the collection.
Dim drawCurve As DrawingCurve
For Each drawCurve In drawcurves
Dim segment As DrawingCurveSegment
For Each segment In drawCurve.Segments
objColl.Add segment
Next
Next
' Change the layer of all of the segments.
Call drawView.Parent.ChangeLayer(objColl, oLayer)
End If
End If
On Error GoTo 0
End If
Else
' It's an assembly so process its contents.
Call ProcessAssemblyColor(drawView, occ.SubOccurrences)
End If
Next
End Sub
------------------
MFG
BlueJay
Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP