Hot News:

Unser Angebot:

  Foren auf CAD.de (alle Foren)
  Inventor VBA
  Bemaßung und dazugehörige Ansicht

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


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

Beiträge: 60
Registriert: 17.02.2011

Inventor2015

erstellt am: 09. Sep. 2016 14:57    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,

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


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

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 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 lumb 10 Unities + Antwort hilfreich

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


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

Beiträge: 4
Registriert: 18.03.2019

erstellt am: 18. Mrz. 2019 09:45    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 lumb 10 Unities + Antwort hilfreich

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


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

Beiträge: 4
Registriert: 18.03.2019

erstellt am: 18. Mrz. 2019 09:45    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 lumb 10 Unities + Antwort hilfreich

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


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

Beiträge: 4
Registriert: 18.03.2019

erstellt am: 18. Mrz. 2019 11:09    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 lumb 10 Unities + Antwort hilfreich

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


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

Beiträge: 4
Registriert: 18.03.2019

erstellt am: 18. Mrz. 2019 11:10    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 lumb 10 Unities + Antwort hilfreich

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

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)2023 CAD.de | Impressum | Datenschutz