Hot News aus dem CAD.de-Newsletter:

Unser Angebot:

  Foren auf CAD.de (alle Foren)
  Inventor VBA
  XYZ-Koordinate und Bezeichnung von einem Punkt in der Zeichnung anzeigen

Antwort erstellen  Neues Thema erstellen
CAD.de Login | Logout | Profil | Profil bearbeiten | Registrieren | Voreinstellungen | Hilfe | Suchen

Anzeige:

Darstellung des Themas zum Ausdrucken. Bitte dann die Druckfunktion des Browsers verwenden. | Suche nach Beiträgen nächster neuer Beitrag | nächster älterer Beitrag
Autor Thema:   XYZ-Koordinate und Bezeichnung von einem Punkt in der Zeichnung anzeigen (123 mal gelesen)
Thomas Thomas
Mitglied


Sehen Sie sich das Profil von Thomas Thomas an!   Senden Sie eine Private Message an Thomas Thomas  Schreiben Sie einen Gästebucheintrag für Thomas Thomas

Beiträge: 7
Registriert: 27.02.2020

erstellt am: 22. Mai. 2020 21:06    Editieren oder löschen Sie diesen Beitrag!  <-- editieren / zitieren -->   Antwort mit Zitat in Fett Antwort mit kursivem Zitat    Unities abgeben: 1 Unity (wenig hilfreich, aber dennoch)2 Unities3 Unities4 Unities5 Unities6 Unities7 Unities8 Unities9 Unities10 Unities

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

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

rkauskh
Moderator
Dipl.-Ing. (FH) Versorgungstechnik


Sehen Sie sich das Profil von rkauskh an!   Senden Sie eine Private Message an rkauskh  Schreiben Sie einen Gästebucheintrag für rkauskh

Beiträge: 1607
Registriert: 15.11.2006

Windows 10 x64, Inventor 2020

erstellt am: 23. Mai. 2020 09:33    Editieren oder löschen Sie diesen Beitrag!  <-- editieren / zitieren -->   Antwort mit Zitat in Fett Antwort mit kursivem Zitat    Unities abgeben: 1 Unity (wenig hilfreich, aber dennoch)2 Unities3 Unities4 Unities5 Unities6 Unities7 Unities8 Unities9 Unities10 Unities Nur für Thomas Thomas 10 Unities + Antwort hilfreich

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

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

Thomas Thomas
Mitglied


Sehen Sie sich das Profil von Thomas Thomas an!   Senden Sie eine Private Message an Thomas Thomas  Schreiben Sie einen Gästebucheintrag für Thomas Thomas

Beiträge: 7
Registriert: 27.02.2020

erstellt am: 23. Mai. 2020 12:13    Editieren oder löschen Sie diesen Beitrag!  <-- editieren / zitieren -->   Antwort mit Zitat in Fett Antwort mit kursivem Zitat    Unities abgeben: 1 Unity (wenig hilfreich, aber dennoch)2 Unities3 Unities4 Unities5 Unities6 Unities7 Unities8 Unities9 Unities10 Unities

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


Sehen Sie sich das Profil von rkauskh an!   Senden Sie eine Private Message an rkauskh  Schreiben Sie einen Gästebucheintrag für rkauskh

Beiträge: 1607
Registriert: 15.11.2006

Windows 10 x64, Inventor 2020

erstellt am: 23. Mai. 2020 14:15    Editieren oder löschen Sie diesen Beitrag!  <-- editieren / zitieren -->   Antwort mit Zitat in Fett Antwort mit kursivem Zitat    Unities abgeben: 1 Unity (wenig hilfreich, aber dennoch)2 Unities3 Unities4 Unities5 Unities6 Unities7 Unities8 Unities9 Unities10 Unities Nur für Thomas Thomas 10 Unities + Antwort hilfreich

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


Sehen Sie sich das Profil von Thomas Thomas an!   Senden Sie eine Private Message an Thomas Thomas  Schreiben Sie einen Gästebucheintrag für Thomas Thomas

Beiträge: 7
Registriert: 27.02.2020

erstellt am: 24. Mai. 2020 20:01    Editieren oder löschen Sie diesen Beitrag!  <-- editieren / zitieren -->   Antwort mit Zitat in Fett Antwort mit kursivem Zitat    Unities abgeben: 1 Unity (wenig hilfreich, aber dennoch)2 Unities3 Unities4 Unities5 Unities6 Unities7 Unities8 Unities9 Unities10 Unities

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

rkauskh
Moderator
Dipl.-Ing. (FH) Versorgungstechnik


Sehen Sie sich das Profil von rkauskh an!   Senden Sie eine Private Message an rkauskh  Schreiben Sie einen Gästebucheintrag für rkauskh

Beiträge: 1607
Registriert: 15.11.2006

Windows 10 x64, Inventor 2020

erstellt am: 25. Mai. 2020 01:04    Editieren oder löschen Sie diesen Beitrag!  <-- editieren / zitieren -->   Antwort mit Zitat in Fett Antwort mit kursivem Zitat    Unities abgeben: 1 Unity (wenig hilfreich, aber dennoch)2 Unities3 Unities4 Unities5 Unities6 Unities7 Unities8 Unities9 Unities10 Unities Nur für Thomas Thomas 10 Unities + Antwort hilfreich

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 >>)

Darstellung des Themas zum Ausdrucken. Bitte dann die Druckfunktion des Browsers verwenden. | Suche nach Beiträgen

nächster neuerer Beitrag | nächster älterer Beitrag
Antwort erstellen


Diesen Beitrag mit Lesezeichen versehen ... | Nach anderen Beiträgen suchen | CAD.de-Newsletter

Administrative Optionen: Beitrag schliessen | Archivieren/Bewegen | Beitrag melden!

Fragen und Anregungen: Kritik-Forum | Neues aus der Community: Community-Forum

(c)2020 CAD.de | Impressum | Datenschutz