---

Mpolygon.PNG

Hallo Allerseits,

Ich suche aktuell nach einer Möglichkeit Attouts von Mpolygonen durchzuführen.

Ich würde also gerne wie dies bereits bei Attributen möglich ist, ein Attout machen und dies als Textdatei ausgeben und dann in Excel bearbeiten können.

Konkret geht es mir um die Werte unter der Eigenschaften Kategorie "Sonstige":
-Gesamtfläche
-Gesamtumfang

Vielleicht kennt jemand von euch ja eine Lösung.

Vielen Dank im Voraus!

LG. Lukas 

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Hallo Lukas,

Könnte man mit einer VBA - Abfrage aus Excel machen
Zeichnung durchsuchen nach oEnt.ObjectName = "AcDbMPolygon"
und ausgeben von oEnt.Area (Fläche) und oEnt.Perimeter (Umfang)

So könnte das aussehen:

Code:

---

Sub MPoly_Werte()
    'Declaring the necessary variables.
    ' vorher über Extras - Verweise
    ' Verweis setzen auf Autocad 20xx Type Library
    Dim acadApp As AcadApplication
    Dim acadDoc As AcadDocument
    Dim Ent As AcadObject
   
    Dim AktRow As Long

    'Check if AutoCAD is open.
    On Error Resume Next
    Set acadApp = GetObject(, "AutoCAD.Application")
    On Error GoTo 0
    If acadApp Is Nothing Then
      ' Hinweis für den Benutzer Voraussetzungen fürs Programm schaffen
      MsgBox "Bitte zunächst Autocad mit Zeichnung öffnen", vbCritical, "Fehler Zugriff auf Autocad"
      ' und Programm beenden
      Exit Sub
    End If
    'Check if there is an active drawing.
    On Error Resume Next
    Set acadDoc = acadApp.ActiveDocument
    On Error GoTo 0
    If acadDoc Is Nothing Then
      ' Hinweis für den Benutzer Voraussetzungen fürs Programm schaffen
      MsgBox "Bitte zunächst Autocad mit Zeichnung öffnen", vbCritical, "Fehler Zugriff auf Zeichnung"
      ' und Programm beenden
      Exit Sub
    End If
   
   
    ' Überschrift schreiben
    AktRow = 1
    Cells(AktRow, 1) = "Layer"
    Cells(AktRow, 2) = "Fläche"
    Cells(AktRow, 3) = "Umfang"
   
  ' Durchsuchen der Zeichnung im Modell
  For Each Ent In acadDoc.ModelSpace
    If Ent.ObjectName = "AcDbMPolygon" Then
      AktRow = AktRow + 1
      Cells(AktRow, 1) = Ent.Layer
      Cells(AktRow, 2) = Ent.Area
      Cells(AktRow, 3) = Ent.Perimeter
    End If
  Next Ent
End Sub

---

Grüße
Klaus  

[Diese Nachricht wurde von KlaK am 13. Apr. 2021 editiert.]

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP