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	[QUOTE]Original erstellt von rkauskh: [i]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] [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 [/code] [/i][/QUOTE] 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
rkauskh
Beiträge: 1710 / 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