---

Hallo,
mir ist das jetzt schon peinlich. Bin ja hier ständig euch am "nerven".
Wie ist es denn eigentlich, wenn man nachträglich Werte von Ojekten ermittelt.
Es sind zb mehrere Objekte (Rechtecke mit Polylinien gezeichnet) vorhanden.
Der User selektiert einige von denen.
Nun soll von den selektierten Werte übergeben werden (Fläche und Umfang).
Aus dem bisherigen Code, was ich von Stelli und aus dem Forum gefunden habe, habe ich volgendes verbrochen:
Die Probleme:
1. kein sauberer Abbruch. Das Selektieren mit Getentity ist wohl nicht so gut?
2. Die Variableübergabe der Funktion ist wohl auch nicht so geschickt gewählt worden.
Kann mich jemand auf den "sauberen Weg"  wieder bringen? 
Danke
T

Code:

---

Sub test1()
    Dim testi As Variant
    Dim fl As Double, uf As Double
    Dim i As Integer
   
    Do
        i = i + 1
        testi = objektwerte

        Debug.Print "t0= " & testi(0)
        Debug.Print "t1= " & testi(1)
        Debug.Print testi(1)
        fl = fl + testi(0)
      ' uf = uf + testi(1)  'Umfang
        ThisDrawing.Utility.Prompt Chr$(10) & "Gesamtfläche= " & (Format(fl, "##,##0.00")) & _
        " m²" & " mit " & i & " Objekten // "

        Debug.Print "i= " & i
        'If testi(0) = -1 Then Exit Do
        'If testi(0) = 0 Then Exit Do
    Loop
    Debug.Print fl & " : " & i
End Sub

Function objektwerte() As Variant
' Ermittelt Flaechen und Längen Werte des selektierten Objektes
    Dim pl As AcadLWPolyline
    Dim Entity As AcadEntity
    Dim oWert(2) As Double
    Dim i, ij
    Dim point

  On Error GoTo objektwerte_Error

    ThisDrawing.Utility.GetEntity Entity, point, "Stütze selektieren: "
    If UCase(Entity.ObjectName) = UCase("AcDbPolyline") Then
        Set pl = Entity
        oWert(0) = pl.Area  'Fläche
        oWert(1) = pl.Length 'Umfang
       
    End If

    objektwerte = oWert
   

objektwerte_exit:
  Exit Function

objektwerte_Error:
    If Err.Number = -2147352567 Then       
        Resume objektwerte_exit
    End If
    MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure objektwerte of Modul Allgemein"
   

---

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

---

Hallo Tom,
  

Zitat:

---

Original erstellt von tomww:
...
Aus dem bisherigen Code, was ich von Stelli und aus dem Forum gefunden habe, habe ich volgendes verbrochen:...

---

Das war dein Code, nur ein wenig geändert.

Um mögliche Fehler auszuschliessen solltest du vielleicht als Rückgabewert für deine Funktion nicht die Eigenschaft eines Objektes abfragen.

Code:

---

Function Objektwerte(Länge as double, Breite as Double, Fläche as Double, Umfang as Double) as Boolean

---

Wenn ein Rechteck erzeugt wurde gibt die Funktion TRUE zurück, sonst FALSE. Wenn zusätzlich noch die Fläche mit zurückkommen soll, füllst du die Variable einfach in der Funktion ab.

Was du jetzt willst versteh ich nicht ganz. Vielleicht so:
Du bildest ein Selektionset
Mit SeleSet.Selectonscreen fragst du mehrere Objekte ab
Mit For Each Entity in SelSet durchläufst du eine Schleife und liest deine Werte aus.

Oder wie du es machst jedes Objekt einzeln aber dann nach obigen Schema.

Stelli

------------------
Warum lisp'eln wenn's auch anders geht.  
www.ib-stelberg.de

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

---

Servus,
ok, hast mich auf neue Wege gebracht :-)

nun mit deinem Hinweis habe ich nun dieses verwurschtelt:
an dieser Stelle haben ich noch einen Typenfehler:
Set Entity = ThisDrawing.SelectionSets("sstest") . wahrscheinlich weise ich dieses Entity noch falsch zu?

Code:

---

Sub testauswahl()
Dim dummy
Dim fl As Double
Dim Entity As AcadEntity
Dim pl As AcadLWPolyline

dummy = Auswahl("sstest")

    fl = 0
    Set Entity = ThisDrawing.SelectionSets("sstest")
    For Each Entity In ThisDrawing.SelectionSets("sstest")
        If UCase(Entity).ObjectName = UCase("AcDbPolyline") Then
            Set pl = Entity
            fl = fl + pl.Area  'Fläche
            Debug.Print "Fl= " & fl

        End If
    Next

End Sub

Function Auswahl(Auswahlname As String) As String
'Funktion für Objektauswahl
    Dim objSS As AcadSelectionSet
    Dim varPnt1 As Variant
    Dim varPnt2 As Variant
    Dim strOpt As String
    Dim lngMode As Long
    Dim anzi
   
    'Löscht Auswahlsatz fals bereits vorhanden
    For Each objSS In ThisDrawing.SelectionSets
        If Auswahlname = objSS.Name Then
            ThisDrawing.SelectionSets.Item(anzi).Delete
            Exit For
        End If
    Next
   
    With ThisDrawing.Utility
        'Selektions Modus
        .InitializeUserInput 1, "Fenster Schneiden Vorheriges Letztes Alles"
        strOpt = .GetKeyword(vbCr & "Wählen [Fenster/Schneiden/Vorheriges/Letztes/Alles]:")
        'in Modus konvertieren
        Select Case strOpt
            Case "Fenster"
                lngMode = acSelectionSetWindow
            Case "Schneiden"
                lngMode = acSelectionSetCrossing
            Case "Vorheriges"
                lngMode = acSelectionSetPrevious
            Case "Letztes"
                lngMode = acSelectionSetLast
            Case "Alles"
                lngMode = acSelectionSetAll
        End Select
       
        'Auswahlset
        Set objSS = ThisDrawing.SelectionSets.Add(Auswahlname)
        ' Fesnter oder Schneiden
        If "Fenster" = strOpt Or "Schneiden" = strOpt Then
            'den ersten Pkt
            .InitializeUserInput 1
            varPnt1 = .GetPoint(, vbCr & "erste Fensterecke: ")
           
            .InitializeUserInput 1 + IIf("Schneiden" = strOpt, 32, 0)
            varPnt2 = .GetCorner(varPnt1, vbCr & "zweite Ecke: ")
           
           
            'anhand der Pnkt selektieren
            objSS.Select lngMode, varPnt1, varPnt2
          Else
            'oder Auswaohl per Modus
            objSS.Select lngMode
        End If
       
        'Auswahl highlight
        objSS.Highlight True
       
        ''Pause
        .GetString False, vbCr & "Weiter mit Eingabe... "
        'Dehighlight
        objSS.Highlight False
       
    End With

  '  If Not objSS Is Nothing Then
  '      objSS.Delete
  '  End If
 

End Function

---

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

---

Hallo Tom,

Zu deinem Typfehler:

    Set Entity = ThisDrawing.SelectionSets("sstest")
    For Each Entity In ThisDrawing.SelectionSets("sstest")

Warum willst du den Auswahlsatz der Variable Entity zuweisen? Du durchläufst doch in der Zeile darunter jedes einzelne Entity im Auswahlsatz. Daher ist die Zeile falsch und kann raus.

Gruß, Carsten

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

---

Morgen,
danke Carsten. Habe noch einen Fehler gefunden, nun scheint es zu laufen.
hier war noch eine Klammerfehler:
If UCase(Entity).ObjectName = UCase("AcDbPolyline") Then

Korrekt:
If UCase(Entity.ObjectName) = UCase("AcDbPolyline") Then

bis sicherlich bald wieder   
T

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