---

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

---

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

---

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

---

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

---

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

---

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