---

Hallo in die Runde ;-)

ich habe mir heute ein Modul gebastelt, welches mir an jedes Segment einer 3D-Polylinie das jeweilige Gefälle schreibt.
Eventuell hilft es ja dem Ein oder Anderen weiter.

Falls noch Jemand Verbesserungen für den Code hat, immer her damit, bin ja schließlich noch Anfänger 

'Dieses Modul berechnet das Gefälle einer 3D-polylinie

Sub Gefälle()

Dim obj As AcadEntity
Dim mitte(0 To 2) As Double

textsize = ThisDrawing.Utility.GetString(0, vbCrLf & "Bitte geben Sie eine TEXTGRÖSSE ein: ")
textsize = Replace(textsize, ".", ",")

    ' Fehlerbehandlung wenn selectionset vorhanden
    On Error Resume Next
        Set ssetOBJ = ThisDrawing.SelectionSets.Add("TEST_SSET")
        If Err.Number <> 0 Then
            ThisDrawing.SelectionSets.Item("TEST_SSET").Delete
            Set ssetOBJ = ThisDrawing.SelectionSets.Add("TEST_SSET")
        End If
    On Error GoTo 0
   
    ' Zeichnung aktivieren
    AppActivate ThisDrawing.Application.Caption

    ' Add objects to a selection set by prompting user to select on the screen
    ssetOBJ.SelectOnScreen
   
 
    For Each obj In ssetOBJ
       

    If obj.ObjectName = "AcDb3dPolyline" Then
    P = 0
        nvertices = (UBound(obj.coordinates) + 1) 'Anzahl der Knickpunkte
        KooPoly = obj.coordinates
       
        For P = 0 To nvertices Step 3
        On Error GoTo ende
       
        If P + 3 >= nvertices Then
            GoTo ende
        End If
       
            X1 = KooPoly(P)
            Y1 = KooPoly(P + 1)
            Z1 = KooPoly(P + 2)
           
            X2 = KooPoly(P + 3)
            Y2 = KooPoly(P + 4)
            Z2 = KooPoly(P + 5)
       
        Länge = Sqr((X2 - X1) ^ 2 + (Y2 - Y1) ^ 2)
        'Debug.Print Länge
       
        difHöhe = Z2 - Z1
        Drehwinkel = Atn((Y2 - Y1) / (X2 - X1))
       
        If Z1 < Z2 Then 'Pfeil nach links oder rechts?
            If Drehwinkel < 0 Then
                Pfeil = ChrW(8594)
            Else
                Pfeil = ChrW(8592)
            End If
        Else
            If Drehwinkel < 0 Then
                Pfeil = ChrW(8592)
            Else
                Pfeil = ChrW(8594)
            End If
        End If
             
        Prozent = Format(Abs((difHöhe / Länge) * 100), "#,##0.00") & "%" & " " & Pfeil
       
       
                  mitte(0) = ((X1 + X2) / 2)
                  mitte(1) = ((Y1 + Y2) / 2) ' Mittelpunkt des Segments
       
           
        Set TextObj = ThisDrawing.ModelSpace.AddMText(mitte, 0.1, Prozent) 'Text platzieren
                    TextObj.Height = textsize 'Textgröße
                    TextObj.Rotation = Drehwinkel 'Drehwinkel berechnen
                    TextObj.AttachmentPoint = acAttachmentPointMiddleCenter 'Text ausrichtung Zentriert
                    TextObj.insertionPoint = mitte 'Text an Position verschieben
                    TextObj.BackgroundFill = True

      Next P
     
    End If
   

ende:
Next
End Sub

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

---

Hallo,

Ja die Tücken der Programmierung ...
Du hast ja schon selber gemerkt dass an dem Code etwas nicht stimmen kann, deshalb die Fehlerabfrage    

Code:

---

        nvertices = (UBound(obj.Coordinates) + 1) 'Anzahl der Knickpunkte <= hier besser: -3
        ' alternativ:
        ' nvertices = UBound(obj.Coordinates) ' Gesamtzahl der Werte
        KooPoly = obj.Coordinates
      
        For P = 0 To nvertices Step 3
        ' alternativ:
        ' For P = 0 To nvertices - 3 Step 3 ' Schleife nur bis vorletzten Punkt

          On Error GoTo ende ' <= kann dann entfallen
      
          If P + 3 >= nvertices Then  ' <= kann dann entfallen
            GoTo ende ' besser wäre: Exit For
          End If

---

Du holst Dir die Anzahl der Koordinatenwerte (nvertices), aber warum erhöhst Du das um einen Wert?
Ich hätte da eher drei abgezogen, denn den letzten Punkt brauchst Du ja nicht, da dieser automatisch durch Dein Programm zugeordnet wird (X2 = KooPoly(P + 3)).
Somit endet die Schleife auch nach dem letzten Streckenelement bzw. vorletztem Stützpunkt und Du kannst Dir das ganze "goto Error" sparen.
Nebenbei: Richtig wäre gewesen die Sprungmarke vor Next P zu setzen (statt for Next ' Obj ), dann würde die Schleife auch ordentlich beendet werden, oder stattdessen ein "Exit For" zu verwenden.

Grüße
Klaus    

[Edit]
Noch was: Die Pfeildarstellung ist bei Drehwinkel < 0 manchmal falsch.
besser wäre:

Code:

---

        pi = Atn(1) * 4 ' oben einfügen
     
        If Z1 < Z2 Then 'Pfeil nach links oder rechts?
          If Drehwinkel < 0 Or Drehwinkel > pi Then ' <= ergänzen
          ' ...
          Else
          ' ...
          End If
        Else
          If Drehwinkel < 0 Or Drehwinkel > pi Then ' <= ergänzen
          ' ...

---

[Diese Nachricht wurde von KlaK am 01. Jun. 2023 editiert.]

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

---

Hallo KlaK!

ja du hast recht. Mit deinen Änderungen ist es eleganter 
Danke Dir!

Ich hatte ursprünglich nvertices = (UBound(obj.Coordinates) + 1) um 1 erhöht, da der erste Wert im Array ja mit (0) andressiert ist und (UBound(obj.Coordinates) somit immer einen Wert zu niedrig war.

Leider habe ich grade festgestellt, dass die Pfeile nicht immer in die korrekte Richtung weisen. Das hängt mit der Textdrehung zusammen.
Hat da eventuell noch Jemand eine Idee?

Code:

---

If Z1 < Z2 Then 'Pfeil nach links oder rechts?
            If Drehwinkel < 0 Then
                Pfeil = ChrW(8594)
            Else
                Pfeil = ChrW(8592)
            End If
        Else
            If Drehwinkel < 0 Then
                Pfeil = ChrW(8592)
            Else
                Pfeil = ChrW(8594)
            End If
        End If

---

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

---

siehe oben .. (ist aber auch noch falsch  )

aber jetzt:

Code:

---

' bei Drehwinkel ergänzen:
        If x2 = x1 Then
          Drehwinkel = pi / 2
        Else
          Drehwinkel = Atn((Y2 - Y1) / (x2 - x1)) ' bei X2 - X1  = 0.0 kommt Fehler !!
        End If

        If X2 >= X1 Then
          If Z1 < Z2 Then 'Pfeil nach links oder rechts?
              Pfeil = ChrW(8592)
          Else
              Pfeil = ChrW(8594)
          End If
        Else
          If Z1 < Z2 Then 'Pfeil nach links oder rechts?
              Pfeil = ChrW(8594)
          Else
              Pfeil = ChrW(8592)
          End If
        End If

---

[Diese Nachricht wurde von KlaK am 01. Jun. 2023 editiert.]

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

---

Läuft! 

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