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: 7 / 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: 1612 / 0

Windows 10 x64, Inventor 2020

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: 7 / 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: 1612 / 0

Windows 10 x64, Inventor 2020

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: 7 / 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: 1612 / 0

Windows 10 x64, Inventor 2020

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