Code:
Option Explicit
Public Sub MoveMarksToLayer()
Dim oApp As Inventor.Application
Set oApp = ThisApplication
If Not oApp.ActiveDocumentType = kDrawingDocumentObject Then
Call MsgBox("Die Funktion ist nur in Zeichnungen verfügbar.", vbExclamation, "MoveMarksToLayer")
Exit Sub
End If
Dim oDrawDoc As DrawingDocument
Set oDrawDoc = oApp.ActiveDocument
Dim oSheet As Sheet
Set oSheet = oDrawDoc.ActiveSheet
Dim oView As DrawingView
Set oView = oApp.CommandManager.Pick(kDrawingViewFilter, "Ansicht wählen... (ESC zum Abbrechen")
If oView Is Nothing Then Exit Sub
Dim oRefDoc As PartDocument
Set oRefDoc = oView.ReferencedDocumentDescriptor.ReferencedDocument
Dim oMarkFeature As MarkFeature
For Each oMarkFeature In oRefDoc.ComponentDefinition.Features.MarkFeatures
Dim oEdges As Edges
Set oEdges = oMarkFeature.ResultEdges()
Dim oLayer As Layer
Set oLayer = GetLayer(oDrawDoc, "MarkFeatures")
Dim oEdge As Edge
For Each oEdge In oEdges
Dim oDrawCurves As DrawingCurvesEnumerator
Set oDrawCurves = oView.DrawingCurves(oEdge)
Dim i As Integer
Dim oDrawCurveSeg As DrawingCurveSegment
For i = 1 To oDrawCurves.Count
For Each oDrawCurveSeg In oDrawCurves(i).Segments
oDrawCurveSeg.Layer = oLayer
Next
Next
Next
Next
End Sub
Private Function GetLayer(ByVal oDrawDoc As DrawingDocument, ByVal sLayerName As String) As Layer
Dim oLayer As Layer
For Each oLayer In oDrawDoc.StylesManager.Layers
If oLayer.Name = "Marks" Then
Set GetLayer = oLayer
Exit For
End If
Next
If oLayer Is Nothing Then Set GetLayer = CreateLayer(oDrawDoc, sLayerName)
End Function
Private Function CreateLayer(ByVal oDrawDoc As DrawingDocument, ByVal sLayerName As String) As Layer
Dim oLayer As Layer
Set oLayer = oDrawDoc.StylesManager.Layers.Item(1).Copy(sLayerName)
oLayer.LineType = kDottedLineType
oLayer.LineWeight = 0.05
oLayer.Color = ThisApplication.TransientObjects.CreateColor(0, 0, 0)
oLayer.ScaleByLineWeight = True
Set CreateLayer = oLayer
End Function
Foren auf CAD.de
| 
