---

Hallo Forum,

ich habe eine DWG bekommen in der sind
Standorte mit dem Element "Ring" erfasst worden. Ich möchte gerne die Einfügepunkte
ermitteln oder die Ringe durch Punkte ersetzen. Gibt es ein Werkzeug oder Worksround, der mir hier helfen kann?

Liebe Grüße Björn

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

---

Hallo,
Variante 1
-Ringe in Regionen umwandeln
-mit MASSEIG u.a. den Schwerpunkt abfragen
-in Datei schreiben
-Datei bearbeiten
-über ein script die Schwerpunkte als Punkte einfügen oder mit map ASCII-Punkte importieren

Variante 2
-Ringe mit MAPEXPORT in shp-Datei exportieren
-mit einem GIS-Programm aus dem Polygonlayer einen Punktlayer (aus den Zentroiden)erstellen
-mit map diesen Punktlayer über MAPIMPORT einlesen

------------------

Gruß Thomas
CADdog the dog formerly known as TR

AutoCAD spricht mit einem, aber viele hören nicht zu.

[Diese Nachricht wurde von CADdog am 27. Aug. 2021 editiert.]

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

---

Danke Thomas

Dies werde ich gleich versuchen.

Toll das Du die Frage auch in diesem Unterforum (VBA) beantwortet hast.

Gestern habe ich erst zu spät gemerkt, das ich die Frage nicht unter [Allgemein CAD] oder [LISP] abgelegt habe.

Kann ich als Nutzer so eine falsche Einsortierung eigentlich selbst korrigieren?

Gruß Björn

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

---

Zitat:

---

Original erstellt von Björn Möller:

Kann ich als Nutzer so eine falsche Einsortierung eigentlich selbst korrigieren?

---

Nein, das geht nicht.
Entweder den Moderator bitten, den Beitrag zu verschieben, das kann aber dauern,
oder im richtigen Forum einen neuen Beitrag erstellen und dann im falschen Beitag durch Editieren einen link dorthin setzen.

------------------

Gruß Thomas
CADdog the dog formerly known as TR

AutoCAD spricht mit einem, aber viele hören nicht zu.

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

---

Danke

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

---

Hast Du mal eine Zeichnung mit einem Beispielelement?

Grüße
Klaus   

Edit: Gerade mal getestet, der Ring in VBA wurde hier ja schon mal behandelt
Daraus folgt dass man mit einem kleinen Programm den Mittelpunkt leicht ermitteln könnte:

Code:

---

Sub RingMitte()
  
    Dim plineObj As AcadLWPolyline
    Dim pObj As AcadPoint
    Dim points As Variant
    Dim center(0 To 2) As Double
    Dim Ent As AcadObject
   

RETRY:
On Error Resume Next
    ThisDrawing.Utility.GetEntity Ent, Base, "Ring auswählen"
    If Err <> 0 Then
        Err.Clear
        MsgBox "Program ended.", , "GetEntity Example"
        Exit Sub
    Else
On Error GoTo errHandler
        If Ent.ObjectName = "AcDbPolyline" Then
          Set plineObj = Ent
          bulge = plineObj.GetBulge(0)
          If bulge = 1 Then
            points = plineObj.Coordinates
            If UBound(points) = 3 Then ' Ring hat 4 Koordinaten
              center(0) = (points(0) + points(2)) / 2
              center(1) = (points(1) + points(3)) / 2
              center(2) = plineObj.Elevation
              MsgBox "Ringmittelpunkt:" & vbCrLf & Str(center(0)) & ", " & Str(center(1)) & ", " & Str(center(2))
              ' Acad Punkt setzen
              Set pObj = ThisDrawing.ModelSpace.AddPoint(center)
            Else
              MsgBox "Polyline ist kein Ring"
            End If ' uBound
          Else
            MsgBox "Gewähltes Element ist kein Ring"
          End If ' Bulge
          points = plineObj.Coordinates ' Coordinates
        Else
          MsgBox "Gewähltes Element ist kein Ring"
        End If
       
    End If

    GoTo RETRY
    Exit Sub
errHandler:
   MsgBox "Fehler " & Err.Number & vbCrLf & Err.Description
   Stop
   Resume Next
End Sub

---

[Diese Nachricht wurde von KlaK am 27. Aug. 2021 editiert.]

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

---

2020-06-13_FW_Einsatz_gesamt-nurRinge.dwg

Hallo Klaus,

danke für Deine Lösung.
Ich werde mich mal einlesen, damit ich das in Schleife laufen lassen kann.
Anbei die DWG mit den Ringen.

Gruß Björn

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

---

Hallo Björn,

Danke für die Zeichnung, mit einem Selectionset kann man das ganz schnell machen lassen:

Code:

---

    Sub RingMitte()
     
        Dim plineObj As AcadLWPolyline
        Dim pObj As AcadPoint
        Dim points As Variant
        Dim center(0 To 2) As Double
        Dim Ent As AcadObject
        Dim bRing As Boolean
        Dim SS1 As AcadSelectionSet
        Dim gpCode(0) As Integer
        Dim dataValue(0) As Variant
        Dim Mode As Variant
       
      
        On Error Resume Next
        Set SS1 = ThisDrawing.SelectionSets("SSET1")
        If Err <> 0 Then
          Set SS1 = ThisDrawing.SelectionSets.Add("SSET1")
          Err.Clear
        End If
        On Error GoTo errHandler
        SS1.Clear
        Mode = acSelectionSetAll
        gpCode(0) = 0
        dataValue(0) = "LWPolyline,POLYLINE"
        SS1.Select Mode, , , gpCode, dataValue
        For Each Ent In SS1
            bRing = False
            If Ent.ObjectName = "AcDbPolyline" Then
              Set plineObj = Ent
              points = plineObj.Coordinates
              bulge = plineObj.GetBulge(0)
              If bulge = 1 Then
                If UBound(points) = 3 Then ' Ring hat 4 Koordinaten
                  center(0) = (points(0) + points(2)) / 2
                  center(1) = (points(1) + points(3)) / 2
                  center(2) = plineObj.Elevation
                  ' Acad Punkt setzen
                  Set pObj = ThisDrawing.ModelSpace.AddPoint(center)
                  bRing = True
                End If ' uBound
              End If ' Bulge
            End If ' Ent.ObjectName
            If bRing = False Then
              Debug.Print "Kein Ring an Pos.: " & Str(points(0)) & "," & Trim(Str(points(1)))
            End If
        Next Ent
        SS1.Delete
        Exit Sub
errHandler:
       MsgBox "Fehler " & Err.Number & vbCrLf & Err.Description
       Stop
       Resume Next
    End Sub

Grüße
Klaus  

---

[Diese Nachricht wurde von KlaK am 30. Aug. 2021 editiert.]

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

---

Danke für Deine große Hilfe und Deine Mühe.
So konnte ich es alles Lösen.

Gruß Björn

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