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

rkauskh Beiträge: 1707 / 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