![]() |
|
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.
Beiträge: 48 / 0 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 Beiträge: 1749 / 0 Windows 10 x64, AIP 2021 Mit der Annahme, dass: Makro starten und Punkt selektieren, die Infos werden angezeigt. Wiederholen für weiteren Punkt, Abbruch zum Beenden. Private Sub PointInfoDemo() Dim oDrawDoc As DrawingDocument Set oDrawDoc = ThisApplication.ActiveDocument Do While oRes = vbRetry oDrawDoc.SelectSet.Clear End Sub Dim oDrawDoc As DrawingDocument Set oDrawDoc = ThisApplication.ActiveDocument Do While oRes = vbYes Set oPointMark = ThisApplication.CommandManager.Pick(kDrawingCentermarkFilter, "Mittelpunkt wählen...") Dim oInsertPoint As Point2d Dim oTG As TransientGeometry Dim oLeaderPoints As ObjectCollection Call oLeaderPoints.Add(oTG.CreatePoint2d(oInsertPoint.X + 1, oInsertPoint.Y + 1)) Dim oGeometryIntent As GeometryIntent Call oLeaderPoints.Add(oGeometryIntent) Dim sText As String Dim oLeaderNote As LeaderNote Dim oFirstNode As LeaderNode oRes = MsgBox("Weiteren Punkt abfragen?", vbYesNo, "Punktinfos") Loop End Sub ------------------ Beiträge: 48 / 0 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 Beiträge: 1749 / 0 Windows 10 x64, AIP 2021 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. Dim oDrawDoc As DrawingDocument Set oDrawDoc = ThisApplication.ActiveDocument Do While oRes = vbYes Set oPointMark = ThisApplication.CommandManager.Pick(kDrawingCentermarkFilter, "Mittelpunkt wählen...") Dim oInsertPoint As Point2d Dim oTG As TransientGeometry Dim oLeaderPoints As ObjectCollection Call oLeaderPoints.Add(oTG.CreatePoint2d(oInsertPoint.X + 1, oInsertPoint.Y + 1)) Dim oGeometryIntent As GeometryIntent Call oLeaderPoints.Add(oGeometryIntent) Dim sText As String Dim oLeaderNote As LeaderNote Dim oFirstNode As LeaderNode oRes = MsgBox("Weiteren Punkt abfragen?", vbYesNo, "Punktinfos") End Sub ------------------ Beiträge: 48 / 0 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? Grüße und einen schönen Abend Thomas Beiträge: 1749 / 0 Windows 10 x64, AIP 2021 Automatisch werden sich die Texte nicht aktualisieren. Reicht auch ein Makro (UpdatePointInfo) für das Aktualisieren aller Punktinfos auf einem Blatt? Dim oDrawDoc As DrawingDocument Set oDrawDoc = ThisApplication.ActiveDocument Do While oRes = vbYes Set oPointMark = ThisApplication.CommandManager.Pick(kDrawingCentermarkFilter, "Mittelpunkt wählen...") Dim oInsertPoint As Point2d Dim oTG As TransientGeometry Dim oLeaderPoints As ObjectCollection Call oLeaderPoints.Add(oTG.CreatePoint2d(oInsertPoint.X + 1, oInsertPoint.Y + 1)) Dim oGeometryIntent As GeometryIntent Call oLeaderPoints.Add(oGeometryIntent) Dim sText As String Dim oLeaderNote As LeaderNote Dim oFirstNode As LeaderNode End Sub Dim oDrawDoc As DrawingDocument Dim oSheet As Sheet Dim oLeaderNote As LeaderNote For Each oLeaderNote In oSheet.DrawingNotes.LeaderNotes End Sub ------------------Thomas Thomas Hallo, rkauskh Moin
- 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.Code:
Option Explicit
Dim oPointMark As Centermark
Dim oPoint As WorkPoint
Dim dX, dY, dZ As Double
Dim oRes As VbMsgBoxResult
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
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 oPointMark As Centermark
Dim oPoint As WorkPoint
Dim dX, dY, dZ As Double
Dim oRes As VbMsgBoxResult
oRes = vbYes
Set oPoint = oPointMark.AttachedEntity
Set oInsertPoint = oPointMark.Position
Set oTG = ThisApplication.TransientGeometry
Set oLeaderPoints = ThisApplication.TransientObjects.CreateObjectCollection
Set oGeometryIntent = oDrawDoc.ActiveSheet.CreateGeometryIntent(oPointMark)
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
Set oLeaderNote = oDrawDoc.ActiveSheet.DrawingNotes.LeaderNotes.Add(oLeaderPoints, sText)
Set oFirstNode = oLeaderNote.Leader.RootNode.ChildNodes.Item(1)
MfG
Ralf Thomas Thomas Hallo Ralf, rkauskh Hallo
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 oPointMark As Centermark
Dim oPoint As WorkPoint
Dim dX, dY, dZ As Double
Dim oRes As VbMsgBoxResult
oRes = vbYes
If Not TypeOf oPointMark.AttachedEntity Is WorkPoint Then
MsgBox "Es sind nur eingeschlossene Arbeitspunkte zulässsig."
GoTo 1
End If
Set oPoint = oPointMark.AttachedEntity
Set oInsertPoint = oPointMark.Position
Set oTG = ThisApplication.TransientGeometry
Set oLeaderPoints = ThisApplication.TransientObjects.CreateObjectCollection
Set oGeometryIntent = oDrawDoc.ActiveSheet.CreateGeometryIntent(oPointMark)
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
Set oLeaderNote = oDrawDoc.ActiveSheet.DrawingNotes.LeaderNotes.Add(oLeaderPoints, sText)
Set oFirstNode = oLeaderNote.Leader.RootNode.ChildNodes.Item(1)
1:
Loop
MfG
Ralf Thomas Thomas Hallo Ralf,
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 91rkauskh Hallo
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 oPointMark As Centermark
Dim oPoint As WorkPoint
Dim dX, dY, dZ As Double
Dim oRes As VbMsgBoxResult
oRes = vbYes
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
Set oInsertPoint = oPointMark.Position
Set oTG = ThisApplication.TransientGeometry
Set oLeaderPoints = ThisApplication.TransientObjects.CreateObjectCollection
Set oGeometryIntent = oDrawDoc.ActiveSheet.CreateGeometryIntent(oPointMark)
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
Set oLeaderNote = oDrawDoc.ActiveSheet.DrawingNotes.LeaderNotes.Add(oLeaderPoints, sText)
Set oFirstNode = oLeaderNote.Leader.RootNode.ChildNodes.Item(1)
Call oLeaderNote.AttributeSets.Add("PointInfo")
oRes = MsgBox("Weiteren Punkt abfragen?", vbYesNo, "Punktinfos")
1:
LoopCode:
Private Sub UpdatePointInfo()
Set oDrawDoc = ThisApplication.ActiveDocument
Set oSheet = oDrawDoc.ActiveSheet
Dim oAttrSet As AttributeSet
Dim oPoint As WorkPoint
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
MfG
Ralf