Für Diejenigen die es interessiert hier der funktionierende Code. Er fügt eine Teileliste ein, die oberhalb des Zeichnungskopfes (entsprechende Abmasse muss man anpassen) verankert wird und je nach dem ob es ein Assembly oder ein Part ist wird ein entsprechender Stil gewählt.
Public Sub StuecklisteEinfügen()
On Error Resume Next
' Set a reference to the drawing document.
' This assumes a drawing document is active.
Dim oDrawDoc As DrawingDocument
Set oDrawDoc = ThisApplication.ActiveDocument
'Set a reference to the active sheet.
Dim oSheet As Sheet
Set oSheet = oDrawDoc.ActiveSheet
' Set a reference to the first drawing view on
' the sheet. This assumes the first drawing
' view on the sheet is not a draft view.
If oSheet.DrawingViews.Count > 0 Then
Dim oDrawingView As DrawingView
Set oDrawingView = oSheet.DrawingViews(1)
Debug.Print "Erstansicht = " & oDrawingView.Name
Else
MsgBox "Bitte erstellen Sie zuerst eine Erstansicht!"
GoTo AbbruchMarker
End If
' Set a reference to th sheet's border
Dim oBorder As Border
Set oBorder = oSheet.Border
' Einfügepunkt der Stückliste
Dim oPlacementPoint As Point2d
' erste position der Teileliste
Set oPlacementPoint = ThisApplication.TransientGeometry.CreatePoint2d(0, 0)
Dim oPLDimensionPoint As Point2d
' Teileliste erstellen
Dim oPartsList As PartsList
Set oPartsList = oSheet.PartsLists.Add(oDrawingView, oPlacementPoint)
' Unterer linker Eckpunt der Teileliste auslesen
Set oPLDimensionPoint = oPartsList.RangeBox.MinPoint
'Debug.Print "1. oPLDimensionPoint => X= " & oPLDimensionPoint.X & " // Y= " & oPLDimensionPoint.Y
' Eckpunkte des Rahmens auslesen
Dim oLeftBottomPoint As Point2d
Dim oRightUpperPoint As Point2d
If Not oBorder Is Nothing Then
' A border exists. The placement point
' is the top-right corner of the border.
Set oLeftBottomPoint = oBorder.RangeBox.MinPoint
Set oRightUpperPoint = oBorder.RangeBox.MaxPoint
Else
MsgBox "Kein Rahmen Eingefügt!"
Dim oNoBorderPoint As Point2d
Set oNoBorderPoint = ThisApplication.TransientGeometry.CreatePoint2d(0, 0)
Set oLeftBottomPoint = oNoBorderPoint
Set oRightUpperPoint = oNoBorderPoint
End If
' Höhe und breite des Zeichnungskopfes in einen Vektor
Dim oVec As Vector2d
' Abmasse des Zeichnungskopfens plus Höhe des Zeichnungskopfes
Set oVec = ThisApplication.TransientGeometry.CreateVector2d(18.4, 5.7 - oPLDimensionPoint.Y)
' Positionsvektor erstellen
Dim oDisplacementVector As Vector2d
Set oDisplacementVector = ThisApplication.TransientGeometry.CreateVector2d(oRightUpperPoint.X, oLeftBottomPoint.Y + oVec.Y)
' Mess-Stückliste entfernen
Call oPartsList.Delete
' Einfügepunkt verschieben
Call oPlacementPoint.TranslateBy(oDisplacementVector)
' Stückliste am korrekten Einfügepunkt einfügen
Set oPartsList = oSheet.PartsLists.Add(oDrawingView, oPlacementPoint)
'Aktuelle Stüli referenzieren
Dim oActualPartsList As PartsList
Set oActualPartsList = oSheet.PartsLists.Item(1)
' PartsListStyles Objekt erzeugen und belegen mit der Baugruppen-Stückliste Deutsch
Dim oStyle As PartsListStyle
Set oStyle = oDrawDoc.StylesManager.PartsListStyles.Item(1)
' Zuweisen der Stücklisten-Stile für Baugruppe und Einzelteil
If oDrawingView.ReferencedDocumentDescriptor.ReferencedDocumentType = kAssemblyDocumentObject Then
Set oStyle = oDrawDoc.StylesManager.PartsListStyles.Item(1)
ElseIf oDrawingView.ReferencedDocumentDescriptor.ReferencedDocumentType = kPartDocumentObject Then
Set oStyle = oDrawDoc.StylesManager.PartsListStyles.Item(2)
Else
Set oStyle = oDrawDoc.StylesManager.PartsListStyles.Item(1)
MsgBox "Konnte Dokumenttyp der Standardansicht nicht erkennen"
End If
' Stil zuweisen
oActualPartsList.Style = oStyle
' Teileliste sortieren
Call PartsListSort
AbbruchMarker:
End Sub
Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP