| | | Gut zu wissen: Hilfreiche Tipps und Tricks aus der Praxis prägnant, und auf den Punkt gebracht für Autodesk Produkte |
Autor
|
Thema: XYZ-Koordinate und Bezeichnung von einem Punkt in der Zeichnung anzeigen (1589 mal gelesen)
|
Thomas Thomas Mitglied
Beiträge: 49 Registriert: 27.02.2020
|
erstellt am: 22. Mai. 2020 21:06 <-- editieren / zitieren --> Unities abgeben:
|
rkauskh Moderator Dipl.-Ing. (FH) Versorgungstechnik
Beiträge: 2166 Registriert: 15.11.2006 Windows 10 x64, AIP 2022
|
erstellt am: 23. Mai. 2020 09:33 <-- editieren / zitieren --> Unities abgeben: Nur für Thomas Thomas
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 ExplicitPrivate 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 Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP |
Thomas Thomas Mitglied
Beiträge: 49 Registriert: 27.02.2020
|
erstellt am: 23. Mai. 2020 12:13 <-- editieren / zitieren --> Unities abgeben:
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 Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP |
rkauskh Moderator Dipl.-Ing. (FH) Versorgungstechnik
Beiträge: 2166 Registriert: 15.11.2006 Windows 10 x64, AIP 2022
|
erstellt am: 23. Mai. 2020 14:15 <-- editieren / zitieren --> Unities abgeben: Nur für Thomas Thomas
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 Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP |
Thomas Thomas Mitglied
Beiträge: 49 Registriert: 27.02.2020
|
erstellt am: 24. Mai. 2020 20:01 <-- editieren / zitieren --> Unities abgeben:
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 Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP |
| Konstruktionsingenieur (m/w/d) | Digitale Transformation. Nachhaltigkeit. Friedenssicherung. Spannende Aufgaben, an denen auch wir bei Diehl in unseren fünf Teilkonzernen Metall, Controls, Defence, Aviation und Metering und unsere über 16.000 Mitarbeiterinnen und Mitarbeiter mit Hochdruck arbeiten. Entdecken Sie faszinierende Technologien und bewerben Sie sich. In einem von Vertrauen und Mut geprägten Familienunternehmen, das beständig und stabil ist ? aus Tradition.... | Anzeige ansehen | Konstruktion, Visualisierung |
|
rkauskh Moderator Dipl.-Ing. (FH) Versorgungstechnik
Beiträge: 2166 Registriert: 15.11.2006 Windows 10 x64, AIP 2022
|
erstellt am: 25. Mai. 2020 01:04 <-- editieren / zitieren --> Unities abgeben: Nur für Thomas Thomas
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 Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP |
| Anzeige.:
Anzeige: (Infos zum Werbeplatz >>)
|