Foren auf CAD.de - Antwort auf einen Beitrag

Forum:	Inventor VBA
Thema:	XYZ-Koordinate und Bezeichnung von einem Punkt in der Zeichnung anzeigen

Möchten Sie sich registrieren?

Wer darf antworten?	Registrierte Benutzer können Beiträge verfassen.
Hinweise zur Registrierung	Sie müssen registriert sein, um Beiträge oder Antworten auf Beiträge schreiben zu können.
Ihr Benutzername:
Ihr Kennwort:	Kennwort vergessen?
Anhang:	Datei(en) anhängen <?> Anhänge verwalten <?>
Grafik für den Beitrag:
Ihre Antwort: Fachbegriff URL Email Fett Kursiv ~~Durchgestr.~~ Liste * Bild Zitat Code HTML ist AUS UBB-Code ist AN Smilies Legende Netiquette	10 20 40
Optionen	Smilies in diesem Beitrag deaktivieren. Signatur anfügen: die Sie bei den Voreinstellungen angegeben haben.

Wenn Sie bereits registriert sind, aber Ihr Kennwort vergessen haben, klicken Sie bitte hier.

Bitte drücken Sie nicht mehrfach auf "Antwort speichern".

*Ist HTML- und/oder UBB-Code aktiviert, dann können Sie HTML und/oder UBB Code in Ihrem Beitrag verwenden.

T H E M A A N S E H E N
Thomas Thomas
Beiträge: 48 / 0
Hallo,
ist es möglich die XYZ-Koordinaten und die Bezeichnung von einem Punkt aus der Baugruppe in der Zeichnung anzeigen zu lassen?
Grüße Thomas
rkauskh
Beiträge: 1749 / 0
Windows 10 x64, AIP 2021
Moin
Mit der Annahme, dass:
- ein Arbeitspunkt gemeint ist.
- der Punkt in der Baugruppe und nicht in einer Unterbaugruppe/ einem Bauteil definiert ist.
- mit "Bezeichnung" der Displayname im Modellbrowser gemeint ist.
Makro starten und Punkt selektieren, die Infos werden angezeigt. Wiederholen für weiteren Punkt, Abbruch zum Beenden.
Code:

Option Explicit
Private Sub PointInfoDemo()
Dim oDrawDoc As DrawingDocument
Dim oPointMark As Centermark
Dim oPoint As WorkPoint
Dim dX, dY, dZ As Double
Dim oRes As VbMsgBoxResult
Set oDrawDoc = ThisApplication.ActiveDocument
oRes = vbRetry
Do While oRes = vbRetry
Set oPointMark = ThisApplication.CommandManager.Pick(kDrawingCentermarkFilter, "Mittelpunkt wählen...")
Set oPoint = oPointMark.AttachedEntity
oRes = MsgBox("X: " & Round(oPoint.Point.X * 10, 2) & " mm" & vbCrLf & _
"Y: " & Round(oPoint.Point.Y * 10, 2) & " mm" & vbCrLf & _
"Z: " & Round(oPoint.Point.Z * 10, 2) & " mm" & vbCrLf & vbCrLf & _
"Name: " & oPoint.Name, _
vbRetryCancel, "Punktinfos")

Loop
oDrawDoc.SelectSet.Clear
End Sub

Oder ist mit "anzeigen" z.B. das Einfügen eines Führungslinientextes gemeint? Dann Makro starten und Punkt selektieren, Infos werden eingefügt. Ja für weiteren Punkt, Nein zum Beenden.
Code:

Private Sub PointInfoDemo2()
Dim oDrawDoc As DrawingDocument
Dim oPointMark As Centermark
Dim oPoint As WorkPoint
Dim dX, dY, dZ As Double
Dim oRes As VbMsgBoxResult
Set oDrawDoc = ThisApplication.ActiveDocument
oRes = vbYes
Do While oRes = vbYes
Set oPointMark = ThisApplication.CommandManager.Pick(kDrawingCentermarkFilter, "Mittelpunkt wählen...")
Set oPoint = oPointMark.AttachedEntity
Dim oInsertPoint As Point2d
Set oInsertPoint = oPointMark.Position
Dim oTG As TransientGeometry
Set oTG = ThisApplication.TransientGeometry
Dim oLeaderPoints As ObjectCollection
Set oLeaderPoints = ThisApplication.TransientObjects.CreateObjectCollection
Call oLeaderPoints.Add(oTG.CreatePoint2d(oInsertPoint.X + 1, oInsertPoint.Y + 1))
Dim oGeometryIntent As GeometryIntent
Set oGeometryIntent = oDrawDoc.ActiveSheet.CreateGeometryIntent(oPointMark)
Call oLeaderPoints.Add(oGeometryIntent)
Dim sText As String
sText = "X: " & Round(oPoint.Point.X * 10, 2) & " mm" & vbCrLf & _
"Y: " & Round(oPoint.Point.Y * 10, 2) & " mm" & vbCrLf & _
"Z: " & Round(oPoint.Point.Z * 10, 2) & " mm" & vbCrLf & vbCrLf & _
"Name: " & oPoint.Name
Dim oLeaderNote As LeaderNote
Set oLeaderNote = oDrawDoc.ActiveSheet.DrawingNotes.LeaderNotes.Add(oLeaderPoints, sText)
Dim oFirstNode As LeaderNode
Set oFirstNode = oLeaderNote.Leader.RootNode.ChildNodes.Item(1)
oRes = MsgBox("Weiteren Punkt abfragen?", vbYesNo, "Punktinfos")
Loop
End Sub
------------------
MfG
Ralf
Thomas Thomas
Beiträge: 48 / 0
Hallo Ralf,
viele Dank für die schnelle Antwort. Das zweiter entspricht meinen Vorstellungen, bekomme es aber nicht zum laufen. Es kommt ein Laufzeitfehler 13, Typen unverträglich.
Wie mach ich die Arbeitspunkte in der Zeichnung sichtbar zum anklicken? Zum Test habe ich jetzt einen Arbeitspunkt in eine Bohrungsmitte gelegt. Das auswählen funktionierte aber dann kam der Fehler.
Danke
Grüße Thomas
rkauskh
Beiträge: 1749 / 0
Windows 10 x64, AIP 2021
Hallo
Hab das Makro nochmal ein wenig präzisiert, dass nur Arbeitspunkte akzeptiert werden. Damit sollte der Fehler weg sein. Du hast eine Mittelpunktmarkierung in der Bohrungsmitte erstellt. Das ist ein Punkt, der nur auf dem Zeichnungsblatt existiert und keine Entsprechung im 3D-Modell hat. Damit kann man keine Koordinaten im dreidimensionalen Raum ermitteln.
Im Modellbrowser der Zeichnung mit der rechten Maustaste auf den Arbeitspunkt klicken und "Einschließen" auswählen. Funktioniert mit dem Ursprung ebenso.
Man kann auch Arbeitspunkte von Unterbaugruppen und Bauteilen einschließen und die Koordinaten anzeigen lassen. ABER, die Koordinaten sind aus dem Koordinatensystem der Baugruppe. Zum Test, eine Baugruppe mit zwei mal dem gleichen Bauteil erstellen. In dem Bauteil einen Arbeitspunkt erstellen und in der Zeichnung die beiden Arbeitpunkte einschließen und Makro anwenden. Die Koordinaten werden unterschiedlich sein.

Code:

Private Sub PointInfoDemo2()
Dim oDrawDoc As DrawingDocument
Dim oPointMark As Centermark
Dim oPoint As WorkPoint
Dim dX, dY, dZ As Double
Dim oRes As VbMsgBoxResult
Set oDrawDoc = ThisApplication.ActiveDocument
oRes = vbYes
Do While oRes = vbYes
Set oPointMark = ThisApplication.CommandManager.Pick(kDrawingCentermarkFilter, "Mittelpunkt wählen...")
If Not TypeOf oPointMark.AttachedEntity Is WorkPoint Then
MsgBox "Es sind nur eingeschlossene Arbeitspunkte zulässsig."
GoTo 1
End If

Set oPoint = oPointMark.AttachedEntity
Dim oInsertPoint As Point2d
Set oInsertPoint = oPointMark.Position
Dim oTG As TransientGeometry
Set oTG = ThisApplication.TransientGeometry
Dim oLeaderPoints As ObjectCollection
Set oLeaderPoints = ThisApplication.TransientObjects.CreateObjectCollection
Call oLeaderPoints.Add(oTG.CreatePoint2d(oInsertPoint.X + 1, oInsertPoint.Y + 1))
Dim oGeometryIntent As GeometryIntent
Set oGeometryIntent = oDrawDoc.ActiveSheet.CreateGeometryIntent(oPointMark)
Call oLeaderPoints.Add(oGeometryIntent)
Dim sText As String
sText = "X: " & Round(oPoint.Point.X * 10, 2) & " mm" & vbCrLf & _
"Y: " & Round(oPoint.Point.Y * 10, 2) & " mm" & vbCrLf & _
"Z: " & Round(oPoint.Point.Z * 10, 2) & " mm" & vbCrLf & vbCrLf & _
"Name: " & oPoint.Name
Dim oLeaderNote As LeaderNote
Set oLeaderNote = oDrawDoc.ActiveSheet.DrawingNotes.LeaderNotes.Add(oLeaderPoints, sText)
Dim oFirstNode As LeaderNode
Set oFirstNode = oLeaderNote.Leader.RootNode.ChildNodes.Item(1)
oRes = MsgBox("Weiteren Punkt abfragen?", vbYesNo, "Punktinfos")
1:
Loop
End Sub
------------------
MfG
Ralf
Thomas Thomas
Beiträge: 48 / 0
Hallo Ralf,
das ist genau was ich gesucht habe. Vielen lieben Dank. Ich hätte noch zwei Fragen dazu.
1. ist es möglich das die Werte und der Name akt. wird wenn es Veränderungen gibt?
2. wenn man gewählt hat das man einen weiteren Punkt auswählen möchte und dann aber doch keinen Punkt auswählt und ESC drückt kommt ein Laufzeitfehler 91
Grüße und einen schönen Abend
Thomas
rkauskh
Beiträge: 1749 / 0
Windows 10 x64, AIP 2021
Hallo
Automatisch werden sich die Texte nicht aktualisieren. Reicht auch ein Makro (UpdatePointInfo) für das Aktualisieren aller Punktinfos auf einem Blatt?
Die Fehlermeldung beim ESC Drücken sollte jetzt weg sein.

EDIT:
Als Automatismus könnte man eine iLogic-Regel erstellen, die nur ein InventorVb.RunMacro("projectName", "moduleName", "macroName") enthält. Dazu noch einen Ereignisauslöser "Vor dem Speichern" oder "Änderung der Zeichnungsansicht".
Code:

Private Sub PointInfoDemo2()
Dim oDrawDoc As DrawingDocument
Dim oPointMark As Centermark
Dim oPoint As WorkPoint
Dim dX, dY, dZ As Double
Dim oRes As VbMsgBoxResult
Set oDrawDoc = ThisApplication.ActiveDocument
oRes = vbYes
Do While oRes = vbYes
Set oPointMark = ThisApplication.CommandManager.Pick(kDrawingCentermarkFilter, "Mittelpunkt wählen...")
If oPointMark Is Nothing Then Exit Do
If Not TypeOf oPointMark.AttachedEntity Is WorkPoint Then
MsgBox "Es sind nur eingeschlossene Arbeitspunkte zulässsig."
GoTo 1
End If

Set oPoint = oPointMark.AttachedEntity
Dim oInsertPoint As Point2d
Set oInsertPoint = oPointMark.Position
Dim oTG As TransientGeometry
Set oTG = ThisApplication.TransientGeometry
Dim oLeaderPoints As ObjectCollection
Set oLeaderPoints = ThisApplication.TransientObjects.CreateObjectCollection
Call oLeaderPoints.Add(oTG.CreatePoint2d(oInsertPoint.X + 1, oInsertPoint.Y + 1))
Dim oGeometryIntent As GeometryIntent
Set oGeometryIntent = oDrawDoc.ActiveSheet.CreateGeometryIntent(oPointMark)
Call oLeaderPoints.Add(oGeometryIntent)
Dim sText As String
sText = "X: " & Round(oPoint.Point.X * 10, 2) & " mm" & vbCrLf & _
"Y: " & Round(oPoint.Point.Y * 10, 2) & " mm" & vbCrLf & _
"Z: " & Round(oPoint.Point.Z * 10, 2) & " mm" & vbCrLf & vbCrLf & _
"Name: " & oPoint.Name
Dim oLeaderNote As LeaderNote
Set oLeaderNote = oDrawDoc.ActiveSheet.DrawingNotes.LeaderNotes.Add(oLeaderPoints, sText)
Dim oFirstNode As LeaderNode
Set oFirstNode = oLeaderNote.Leader.RootNode.ChildNodes.Item(1)

Call oLeaderNote.AttributeSets.Add("PointInfo")

oRes = MsgBox("Weiteren Punkt abfragen?", vbYesNo, "Punktinfos")
1:
Loop
End Sub

Code:

Private Sub UpdatePointInfo()
Dim oDrawDoc As DrawingDocument
Set oDrawDoc = ThisApplication.ActiveDocument
Dim oSheet As Sheet
Set oSheet = oDrawDoc.ActiveSheet
Dim oLeaderNote As LeaderNote
Dim oAttrSet As AttributeSet
Dim oPoint As WorkPoint
For Each oLeaderNote In oSheet.DrawingNotes.LeaderNotes
For Each oAttrSet In oLeaderNote.AttributeSets
If oAttrSet.Name = "PointInfo" Then
Set oPoint = oLeaderNote.Leader.AllLeafNodes.Item(1).AttachedEntity.Geometry.AttachedEntity
Dim sText As String
sText = "X: " & Round(oPoint.Point.X * 10, 2) & " mm" & vbCrLf & _
"Y: " & Round(oPoint.Point.Y * 10, 2) & " mm" & vbCrLf & _
"Z: " & Round(oPoint.Point.Z * 10, 2) & " mm" & vbCrLf & vbCrLf & _
"Name: " & oPoint.Name
oLeaderNote.Text = sText
End If
Next
Next
End Sub
------------------
MfG
Ralf

T H E M A A N S E H E N
Thomas Thomas Beiträge: 48 / 0	Hallo, ist es möglich die XYZ-Koordinaten und die Bezeichnung von einem Punkt aus der Baugruppe in der Zeichnung anzeigen zu lassen? Grüße Thomas
rkauskh Beiträge: 1749 / 0 Windows 10 x64, AIP 2021	Moin Mit der Annahme, dass: - ein Arbeitspunkt gemeint ist. - der Punkt in der Baugruppe und nicht in einer Unterbaugruppe/ einem Bauteil definiert ist. - mit "Bezeichnung" der Displayname im Modellbrowser gemeint ist. Makro starten und Punkt selektieren, die Infos werden angezeigt. Wiederholen für weiteren Punkt, Abbruch zum Beenden. Code: Option Explicit Private Sub PointInfoDemo() Dim oDrawDoc As DrawingDocument Dim oPointMark As Centermark Dim oPoint As WorkPoint Dim dX, dY, dZ As Double Dim oRes As VbMsgBoxResult Set oDrawDoc = ThisApplication.ActiveDocument oRes = vbRetry Do While oRes = vbRetry Set oPointMark = ThisApplication.CommandManager.Pick(kDrawingCentermarkFilter, "Mittelpunkt wählen...") Set oPoint = oPointMark.AttachedEntity oRes = MsgBox("X: " & Round(oPoint.Point.X * 10, 2) & " mm" & vbCrLf & _ "Y: " & Round(oPoint.Point.Y * 10, 2) & " mm" & vbCrLf & _ "Z: " & Round(oPoint.Point.Z * 10, 2) & " mm" & vbCrLf & vbCrLf & _ "Name: " & oPoint.Name, _ vbRetryCancel, "Punktinfos") Loop oDrawDoc.SelectSet.Clear End Sub Oder ist mit "anzeigen" z.B. das Einfügen eines Führungslinientextes gemeint? Dann Makro starten und Punkt selektieren, Infos werden eingefügt. Ja für weiteren Punkt, Nein zum Beenden. Code: Private Sub PointInfoDemo2() Dim oDrawDoc As DrawingDocument Dim oPointMark As Centermark Dim oPoint As WorkPoint Dim dX, dY, dZ As Double Dim oRes As VbMsgBoxResult Set oDrawDoc = ThisApplication.ActiveDocument oRes = vbYes Do While oRes = vbYes Set oPointMark = ThisApplication.CommandManager.Pick(kDrawingCentermarkFilter, "Mittelpunkt wählen...") Set oPoint = oPointMark.AttachedEntity Dim oInsertPoint As Point2d Set oInsertPoint = oPointMark.Position Dim oTG As TransientGeometry Set oTG = ThisApplication.TransientGeometry Dim oLeaderPoints As ObjectCollection Set oLeaderPoints = ThisApplication.TransientObjects.CreateObjectCollection Call oLeaderPoints.Add(oTG.CreatePoint2d(oInsertPoint.X + 1, oInsertPoint.Y + 1)) Dim oGeometryIntent As GeometryIntent Set oGeometryIntent = oDrawDoc.ActiveSheet.CreateGeometryIntent(oPointMark) Call oLeaderPoints.Add(oGeometryIntent) Dim sText As String sText = "X: " & Round(oPoint.Point.X * 10, 2) & " mm" & vbCrLf & _ "Y: " & Round(oPoint.Point.Y * 10, 2) & " mm" & vbCrLf & _ "Z: " & Round(oPoint.Point.Z * 10, 2) & " mm" & vbCrLf & vbCrLf & _ "Name: " & oPoint.Name Dim oLeaderNote As LeaderNote Set oLeaderNote = oDrawDoc.ActiveSheet.DrawingNotes.LeaderNotes.Add(oLeaderPoints, sText) Dim oFirstNode As LeaderNode Set oFirstNode = oLeaderNote.Leader.RootNode.ChildNodes.Item(1) oRes = MsgBox("Weiteren Punkt abfragen?", vbYesNo, "Punktinfos") Loop End Sub ------------------ MfG Ralf
Thomas Thomas Beiträge: 48 / 0	Hallo Ralf, viele Dank für die schnelle Antwort. Das zweiter entspricht meinen Vorstellungen, bekomme es aber nicht zum laufen. Es kommt ein Laufzeitfehler 13, Typen unverträglich. Wie mach ich die Arbeitspunkte in der Zeichnung sichtbar zum anklicken? Zum Test habe ich jetzt einen Arbeitspunkt in eine Bohrungsmitte gelegt. Das auswählen funktionierte aber dann kam der Fehler. Danke Grüße Thomas
rkauskh Beiträge: 1749 / 0 Windows 10 x64, AIP 2021	Hallo Hab das Makro nochmal ein wenig präzisiert, dass nur Arbeitspunkte akzeptiert werden. Damit sollte der Fehler weg sein. Du hast eine Mittelpunktmarkierung in der Bohrungsmitte erstellt. Das ist ein Punkt, der nur auf dem Zeichnungsblatt existiert und keine Entsprechung im 3D-Modell hat. Damit kann man keine Koordinaten im dreidimensionalen Raum ermitteln. Im Modellbrowser der Zeichnung mit der rechten Maustaste auf den Arbeitspunkt klicken und "Einschließen" auswählen. Funktioniert mit dem Ursprung ebenso. Man kann auch Arbeitspunkte von Unterbaugruppen und Bauteilen einschließen und die Koordinaten anzeigen lassen. ABER, die Koordinaten sind aus dem Koordinatensystem der Baugruppe. Zum Test, eine Baugruppe mit zwei mal dem gleichen Bauteil erstellen. In dem Bauteil einen Arbeitspunkt erstellen und in der Zeichnung die beiden Arbeitpunkte einschließen und Makro anwenden. Die Koordinaten werden unterschiedlich sein. Code: Private Sub PointInfoDemo2() Dim oDrawDoc As DrawingDocument Dim oPointMark As Centermark Dim oPoint As WorkPoint Dim dX, dY, dZ As Double Dim oRes As VbMsgBoxResult Set oDrawDoc = ThisApplication.ActiveDocument oRes = vbYes Do While oRes = vbYes Set oPointMark = ThisApplication.CommandManager.Pick(kDrawingCentermarkFilter, "Mittelpunkt wählen...") If Not TypeOf oPointMark.AttachedEntity Is WorkPoint Then MsgBox "Es sind nur eingeschlossene Arbeitspunkte zulässsig." GoTo 1 End If Set oPoint = oPointMark.AttachedEntity Dim oInsertPoint As Point2d Set oInsertPoint = oPointMark.Position Dim oTG As TransientGeometry Set oTG = ThisApplication.TransientGeometry Dim oLeaderPoints As ObjectCollection Set oLeaderPoints = ThisApplication.TransientObjects.CreateObjectCollection Call oLeaderPoints.Add(oTG.CreatePoint2d(oInsertPoint.X + 1, oInsertPoint.Y + 1)) Dim oGeometryIntent As GeometryIntent Set oGeometryIntent = oDrawDoc.ActiveSheet.CreateGeometryIntent(oPointMark) Call oLeaderPoints.Add(oGeometryIntent) Dim sText As String sText = "X: " & Round(oPoint.Point.X * 10, 2) & " mm" & vbCrLf & _ "Y: " & Round(oPoint.Point.Y * 10, 2) & " mm" & vbCrLf & _ "Z: " & Round(oPoint.Point.Z * 10, 2) & " mm" & vbCrLf & vbCrLf & _ "Name: " & oPoint.Name Dim oLeaderNote As LeaderNote Set oLeaderNote = oDrawDoc.ActiveSheet.DrawingNotes.LeaderNotes.Add(oLeaderPoints, sText) Dim oFirstNode As LeaderNode Set oFirstNode = oLeaderNote.Leader.RootNode.ChildNodes.Item(1) oRes = MsgBox("Weiteren Punkt abfragen?", vbYesNo, "Punktinfos") 1: Loop End Sub ------------------ MfG Ralf
Thomas Thomas Beiträge: 48 / 0	Hallo Ralf, das ist genau was ich gesucht habe. Vielen lieben Dank. Ich hätte noch zwei Fragen dazu. 1. ist es möglich das die Werte und der Name akt. wird wenn es Veränderungen gibt? 2. wenn man gewählt hat das man einen weiteren Punkt auswählen möchte und dann aber doch keinen Punkt auswählt und ESC drückt kommt ein Laufzeitfehler 91 Grüße und einen schönen Abend Thomas
rkauskh Beiträge: 1749 / 0 Windows 10 x64, AIP 2021	Hallo Automatisch werden sich die Texte nicht aktualisieren. Reicht auch ein Makro (UpdatePointInfo) für das Aktualisieren aller Punktinfos auf einem Blatt? Die Fehlermeldung beim ESC Drücken sollte jetzt weg sein. EDIT: Als Automatismus könnte man eine iLogic-Regel erstellen, die nur ein InventorVb.RunMacro("projectName", "moduleName", "macroName") enthält. Dazu noch einen Ereignisauslöser "Vor dem Speichern" oder "Änderung der Zeichnungsansicht". Code: Private Sub PointInfoDemo2() Dim oDrawDoc As DrawingDocument Dim oPointMark As Centermark Dim oPoint As WorkPoint Dim dX, dY, dZ As Double Dim oRes As VbMsgBoxResult Set oDrawDoc = ThisApplication.ActiveDocument oRes = vbYes Do While oRes = vbYes Set oPointMark = ThisApplication.CommandManager.Pick(kDrawingCentermarkFilter, "Mittelpunkt wählen...") If oPointMark Is Nothing Then Exit Do If Not TypeOf oPointMark.AttachedEntity Is WorkPoint Then MsgBox "Es sind nur eingeschlossene Arbeitspunkte zulässsig." GoTo 1 End If Set oPoint = oPointMark.AttachedEntity Dim oInsertPoint As Point2d Set oInsertPoint = oPointMark.Position Dim oTG As TransientGeometry Set oTG = ThisApplication.TransientGeometry Dim oLeaderPoints As ObjectCollection Set oLeaderPoints = ThisApplication.TransientObjects.CreateObjectCollection Call oLeaderPoints.Add(oTG.CreatePoint2d(oInsertPoint.X + 1, oInsertPoint.Y + 1)) Dim oGeometryIntent As GeometryIntent Set oGeometryIntent = oDrawDoc.ActiveSheet.CreateGeometryIntent(oPointMark) Call oLeaderPoints.Add(oGeometryIntent) Dim sText As String sText = "X: " & Round(oPoint.Point.X * 10, 2) & " mm" & vbCrLf & _ "Y: " & Round(oPoint.Point.Y * 10, 2) & " mm" & vbCrLf & _ "Z: " & Round(oPoint.Point.Z * 10, 2) & " mm" & vbCrLf & vbCrLf & _ "Name: " & oPoint.Name Dim oLeaderNote As LeaderNote Set oLeaderNote = oDrawDoc.ActiveSheet.DrawingNotes.LeaderNotes.Add(oLeaderPoints, sText) Dim oFirstNode As LeaderNode Set oFirstNode = oLeaderNote.Leader.RootNode.ChildNodes.Item(1) Call oLeaderNote.AttributeSets.Add("PointInfo") oRes = MsgBox("Weiteren Punkt abfragen?", vbYesNo, "Punktinfos") 1: Loop End Sub Code: Private Sub UpdatePointInfo() Dim oDrawDoc As DrawingDocument Set oDrawDoc = ThisApplication.ActiveDocument Dim oSheet As Sheet Set oSheet = oDrawDoc.ActiveSheet Dim oLeaderNote As LeaderNote Dim oAttrSet As AttributeSet Dim oPoint As WorkPoint For Each oLeaderNote In oSheet.DrawingNotes.LeaderNotes For Each oAttrSet In oLeaderNote.AttributeSets If oAttrSet.Name = "PointInfo" Then Set oPoint = oLeaderNote.Leader.AllLeafNodes.Item(1).AttachedEntity.Geometry.AttachedEntity Dim sText As String sText = "X: " & Round(oPoint.Point.X * 10, 2) & " mm" & vbCrLf & _ "Y: " & Round(oPoint.Point.Y * 10, 2) & " mm" & vbCrLf & _ "Z: " & Round(oPoint.Point.Z * 10, 2) & " mm" & vbCrLf & vbCrLf & _ "Name: " & oPoint.Name oLeaderNote.Text = sText End If Next Next End Sub ------------------ MfG Ralf