Code:
Option Explicit' Fügt einen Führungslinientext ein. Der Text stammt aus dem benutzdef. iProp der übergeordneten Baugruppe
' statischer Text, keine autom. Aktualisierung !!!
' Namen des iProps unten anpassen
Public Sub AddLeaderNote()
' 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 oActiveSheet As Sheet
Set oActiveSheet = oDrawDoc.ActiveSheet
' Set a reference to the drawing curve segment.
' This assumes that a drawing curve is selected.
Dim oDrawingCurveSegment As DrawingCurveSegment
Set oDrawingCurveSegment = ThisApplication.CommandManager.Pick(kDrawingCurveSegmentFilter, "Kante wählen")
' Set a reference to the drawing curve.
Dim oDrawingCurve As DrawingCurve
Set oDrawingCurve = oDrawingCurveSegment.Parent
' Get the mid point of the selected curve
' assuming that the selected curve is linear
Dim oMidPoint As Point2d
Set oMidPoint = oDrawingCurve.MidPoint
' Set a reference to the TransientGeometry object.
Dim oTG As TransientGeometry
Set oTG = ThisApplication.TransientGeometry
Dim oLeaderPoints As ObjectCollection
Set oLeaderPoints = ThisApplication.TransientObjects.CreateObjectCollection
' Create a few leader points.
Call oLeaderPoints.Add(oTG.CreatePoint2d(oMidPoint.X + 2, oMidPoint.Y + 2))
' Create an intent and add to the leader points collection.
' This is the geometry that the leader text will attach to.
Dim oGeometryIntent As GeometryIntent
Set oGeometryIntent = oActiveSheet.CreateGeometryIntent(oDrawingCurve, oMidPoint)
Call oLeaderPoints.Add(oGeometryIntent)
' Create text with simple string as input. Since this doesn't use
' any text overrides, it will default to the active text style.
Dim sText As String
'sText = "API Leader Note"
sText = GetParentAssemblyPropText(oDrawingCurve)
If sText = ":Error:No:Assembly:" Then
MsgBox "Bauteil nicht in Unterbaugruppe. Abbruch", vbCritical
Exit Sub
ElseIf sText = "" Then
MsgBox "Baugruppenpropertie leer. Abbruch", vbCritical
Exit Sub
End If
Dim oLeaderNote As LeaderNote
Set oLeaderNote = oActiveSheet.DrawingNotes.LeaderNotes.Add(oLeaderPoints, sText)
End Sub
Private Function GetParentAssemblyPropText(ByVal oDrawCurve As DrawingCurve) As String
Dim oOcc As ComponentOccurrence
Dim oParentCompDef As AssemblyComponentDefinition
Dim oParentDoc As AssemblyDocument
If TypeOf oDrawCurve.ModelGeometry Is Edge Then
Set oOcc = oDrawCurve.ModelGeometry.ContainingOccurrence
If Not oOcc.ParentOccurrence Is Nothing Then
Set oParentCompDef = oOcc.ContainingOccurrence.Definition
Set oParentDoc = oParentCompDef.Document
Dim oPropSet As PropertySet
Set oPropSet = oParentDoc.PropertySets.Item("{D5CDD505-2E9C-101B-9397-08002B2CF9AE}")
Dim oProp As Property
For Each oProp In oPropSet
If oProp.Name = "MeinPropertie" Then '<--------------------------------------------------- ANPASSEN!!!!!!!!
GetParentAssemblyPropText = oProp.Value
End If
Next
Else
GetParentAssemblyPropText = ":Error:No:Assembly:"
End If
End If
End Function
Foren auf CAD.de (alle Foren)
| 
