| |
| Gut zu wissen: Hilfreiche Tipps und Tricks aus der Praxis prägnant, und auf den Punkt gebracht für Autodesk Produkte |
Autor
|
Thema: Bemaßung und dazugehörige Ansicht (1443 mal gelesen)
|
lumb Mitglied Informatiker
Beiträge: 60 Registriert: 17.02.2011 Inventor2015
|
erstellt am: 09. Sep. 2016 14:57 <-- editieren / zitieren --> Unities abgeben:
Hallo, ich versuche per Makro alle Bemaßungen auszulesen, das klappt, allerdings sind diese direkt unter oSheet. Ich hätte aber gerne die Zugehörigkeit zur Ansicht mit ausgelesen... Diese Makro ermittelt den Wert aller Bemaßungen in einer Zeichnung, ich würde diese aber gerne Filtern, zB nur die Bemaßungen von Ansicht1... Kann mir da jemand helfen? DANKE Sub Pruefmasstabelle() Dim oApp As Application Set oApp = ThisApplication Dim oDoc As DrawingDocument Set oDoc = oApp.ActiveDocument Dim oSheet As Sheet Set oSheet = oDoc.ActiveSheet Dim oView As DrawingView Dim oDrawingDim As DrawingDimension For Each oDrawingDim In oSheet.DrawingDimensions MsgBox oDrawingDim.Text.Text Next End Sub Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP |
metalgod Mitglied Technischer Zeichner, Mädchen für alles
Beiträge: 32 Registriert: 23.09.2015 Win10x64 Prof. Intel Core i7-8700K 3,70GHz, 16GB Ram Inventor Prof. 2018 64-Bit Visual Studio 2015 Express
|
erstellt am: 12. Sep. 2016 14:44 <-- editieren / zitieren --> Unities abgeben: Nur für lumb
Hallo lumb, einen Bezug von einer Bemaßung zur Ansicht könnte man beispielsweise so ermitteln: Code: Public Sub Pruefmasstabelle_2() Dim oApp As Application Set oApp = ThisApplication Dim oDoc As DrawingDocument Set oDoc = oApp.ActiveDocument Dim oSheet As Sheet Set oSheet = oDoc.ActiveSheet Dim oView As DrawingView Dim oDrawingDim As DrawingDimension Dim oGemIntent As GeometryIntent Dim oDrwCurve As DrawingCurve For Each oDrawingDim In oSheet.DrawingDimensions Set oGemIntent = Nothing If oDrawingDim.Type = kRadiusGeneralDimensionObject _ Or oDrawingDim.Type = kDiameterGeneralDimensionObject Then Set oGemIntent = oDrawingDim.Intent ElseIf oDrawingDim.Type = kLinearGeneralDimensionObject _ Or oDrawingDim.Type = kAngularGeneralDimensionObject Then Set oGemIntent = oDrawingDim.IntentOne ' Hier bei Bedarf weitere einfügen. End If If Not oGemIntent Is Nothing Then Set oDrwCurve = oGemIntent.Geometry Set oView = oDrwCurve.Parent Call MsgBox(oDrawingDim.Text.Text & " " & oView.Name) Else Call MsgBox("oGemIntent Is Nothing", vbCritical) End If Next End Sub
------------------ alex Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP |
Markus2019 Mitglied
Beiträge: 4 Registriert: 18.03.2019
|
erstellt am: 18. Mrz. 2019 09:45 <-- editieren / zitieren --> Unities abgeben: Nur für lumb
Hallo, herzlichen Dank für den Post. Allerdings funktioniert der Code nicht ganz zuverlässig. Manchmal ordnet das Makro eine Bemaßung der falschen Ansicht zu. Hat jemand eine Idee woran es liegen kann? Herzliche Grüße Markus Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP |
Markus2019 Mitglied
Beiträge: 4 Registriert: 18.03.2019
|
erstellt am: 18. Mrz. 2019 09:45 <-- editieren / zitieren --> Unities abgeben: Nur für lumb
Hallo, herzlichen Dank für den Post. Allerdings funktioniert der Code nicht ganz zuverlässig. Manchmal ordnet das Makro eine Bemaßung der falschen Ansicht zu. Hat jemand eine Idee woran es liegen kann? Herzliche Grüße Markus Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP |
Markus2019 Mitglied
Beiträge: 4 Registriert: 18.03.2019
|
erstellt am: 18. Mrz. 2019 11:09 <-- editieren / zitieren --> Unities abgeben: Nur für lumb
Also manchmal wird die Zeichnungsansicht in Intenttwo gespeichert. In Intentone ist der Blattname dann. Das hab ich mit folgenden Quellcode abgefangen. Public Sub Pruefmasstabelle_4() Dim oApp As Application Set oApp = ThisApplication Dim oDoc As DrawingDocument Set oDoc = oApp.ActiveDocument Dim oSheet As Sheet Set oSheet = oDoc.ActiveSheet Dim oView As DrawingView Dim oDrawingDim As DrawingDimension Dim oGemIntent As GeometryIntent Dim oDrwCurve As DrawingCurve 'MsgBox ThisApplication.ActiveDocument.Sheets.Item(1).name 'MsgBox ThisApplication.ActiveDocument.ActiveSheet.name For Each oDrawingDim In oSheet.DrawingDimensions Set oGemIntent = Nothing If oDrawingDim.Type = kRadiusGeneralDimensionObject _ Or oDrawingDim.Type = kDiameterGeneralDimensionObject Then Set oGemIntent = oDrawingDim.Intent ElseIf oDrawingDim.Type = kLinearGeneralDimensionObject Then Set oGemIntent = oDrawingDim.IntentOne ElseIf oDrawingDim.Type = kAngularGeneralDimensionObject Then Set oGemIntent = oDrawingDim.IntentOne ' Hier bei Bedarf weitere einfügen. End If If Not oGemIntent Is Nothing Then 'On Error Resume Next name = oGemIntent.Geometry.Parent.name If name = ThisApplication.ActiveDocument.Sheets.Item(1).name Then Set oGemIntent = oDrawingDim.IntentTwo name = oGemIntent.Geometry.Parent.name End If If oDrawingDim.Text.Text = "7,6" Then Call MsgBox(oDrawingDim.Text.Text & " " & name) End If Else Call MsgBox("oGemIntent Is Nothing", vbCritical) End If ende: Next End Sub
Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP |
Markus2019 Mitglied
Beiträge: 4 Registriert: 18.03.2019
|
erstellt am: 18. Mrz. 2019 11:10 <-- editieren / zitieren --> Unities abgeben: Nur für lumb
Also manchmal wird die Zeichnungsansicht in Intenttwo gespeichert. In Intentone ist der Blattname dann. Das hab ich mit folgenden Quellcode abgefangen. Public Sub Pruefmasstabelle_4() Dim oApp As Application Set oApp = ThisApplication Dim oDoc As DrawingDocument Set oDoc = oApp.ActiveDocument Dim oSheet As Sheet Set oSheet = oDoc.ActiveSheet Dim oView As DrawingView Dim oDrawingDim As DrawingDimension Dim oGemIntent As GeometryIntent Dim oDrwCurve As DrawingCurve 'MsgBox ThisApplication.ActiveDocument.Sheets.Item(1).name 'MsgBox ThisApplication.ActiveDocument.ActiveSheet.name For Each oDrawingDim In oSheet.DrawingDimensions Set oGemIntent = Nothing If oDrawingDim.Type = kRadiusGeneralDimensionObject _ Or oDrawingDim.Type = kDiameterGeneralDimensionObject Then Set oGemIntent = oDrawingDim.Intent ElseIf oDrawingDim.Type = kLinearGeneralDimensionObject Then Set oGemIntent = oDrawingDim.IntentOne ElseIf oDrawingDim.Type = kAngularGeneralDimensionObject Then Set oGemIntent = oDrawingDim.IntentOne ' Hier bei Bedarf weitere einfügen. End If If Not oGemIntent Is Nothing Then 'On Error Resume Next name = oGemIntent.Geometry.Parent.name If name = ThisApplication.ActiveDocument.Sheets.Item(1).name Then Set oGemIntent = oDrawingDim.IntentTwo name = oGemIntent.Geometry.Parent.name End If Call MsgBox(oDrawingDim.Text.Text & " " & name) Else Call MsgBox("oGemIntent Is Nothing", vbCritical) End If ende: Next End Sub
Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP |