Hot News:

Unser Angebot:

  Foren auf CAD.de (alle Foren)
  
  Gefälle in Prozent an 3D-Polylinien Schreiben VBA

Antwort erstellen  Neues Thema erstellen
CAD.de Login | Logout | Profil | Profil bearbeiten | Registrieren | Voreinstellungen | Hilfe | Suchen

Anzeige:

Darstellung des Themas zum Ausdrucken. Bitte dann die Druckfunktion des Browsers verwenden. | Suche nach Beiträgen nächster neuer Beitrag | nächster älterer Beitrag
[an error occurred while processing this directive]
  
Gut zu wissen: Hilfreiche Tipps und Tricks aus der Praxis prägnant, und auf den Punkt gebracht für Autodesk Produkte
Autor Thema:  Gefälle in Prozent an 3D-Polylinien Schreiben VBA (287 mal gelesen)
DraftsmanCAD
Mitglied



Sehen Sie sich das Profil von DraftsmanCAD an!   Senden Sie eine Private Message an DraftsmanCAD  Schreiben Sie einen Gästebucheintrag für DraftsmanCAD

Beiträge: 10
Registriert: 08.12.2022

erstellt am: 01. Jun. 2023 12:59    Editieren oder löschen Sie diesen Beitrag!  <-- editieren / zitieren -->   Antwort mit Zitat in Fett Antwort mit kursivem Zitat    Unities abgeben: 1 Unity (wenig hilfreich, aber dennoch)2 Unities3 Unities4 Unities5 Unities6 Unities7 Unities8 Unities9 Unities10 Unities

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

KlaK
Ehrenmitglied V.I.P. h.c.
Dipl. Ing. Vermessung, CAD- und Netz-Admin



Sehen Sie sich das Profil von KlaK an!   Senden Sie eine Private Message an KlaK  Schreiben Sie einen Gästebucheintrag für KlaK

Beiträge: 2693
Registriert: 02.05.2006

AutoCAD LandDesktop R2 bis 2004
Civil 3D 2005 - 2022
Plateia, Canalis
Visual Basic

erstellt am: 01. Jun. 2023 14:34    Editieren oder löschen Sie diesen Beitrag!  <-- editieren / zitieren -->   Antwort mit Zitat in Fett Antwort mit kursivem Zitat    Unities abgeben: 1 Unity (wenig hilfreich, aber dennoch)2 Unities3 Unities4 Unities5 Unities6 Unities7 Unities8 Unities9 Unities10 Unities Nur für DraftsmanCAD 10 Unities + Antwort hilfreich

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

DraftsmanCAD
Mitglied



Sehen Sie sich das Profil von DraftsmanCAD an!   Senden Sie eine Private Message an DraftsmanCAD  Schreiben Sie einen Gästebucheintrag für DraftsmanCAD

Beiträge: 10
Registriert: 08.12.2022

erstellt am: 01. Jun. 2023 15:04    Editieren oder löschen Sie diesen Beitrag!  <-- editieren / zitieren -->   Antwort mit Zitat in Fett Antwort mit kursivem Zitat    Unities abgeben: 1 Unity (wenig hilfreich, aber dennoch)2 Unities3 Unities4 Unities5 Unities6 Unities7 Unities8 Unities9 Unities10 Unities

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

KlaK
Ehrenmitglied V.I.P. h.c.
Dipl. Ing. Vermessung, CAD- und Netz-Admin



Sehen Sie sich das Profil von KlaK an!   Senden Sie eine Private Message an KlaK  Schreiben Sie einen Gästebucheintrag für KlaK

Beiträge: 2693
Registriert: 02.05.2006

AutoCAD LandDesktop R2 bis 2004
Civil 3D 2005 - 2022
Plateia, Canalis
Visual Basic

erstellt am: 01. Jun. 2023 15:14    Editieren oder löschen Sie diesen Beitrag!  <-- editieren / zitieren -->   Antwort mit Zitat in Fett Antwort mit kursivem Zitat    Unities abgeben: 1 Unity (wenig hilfreich, aber dennoch)2 Unities3 Unities4 Unities5 Unities6 Unities7 Unities8 Unities9 Unities10 Unities Nur für DraftsmanCAD 10 Unities + Antwort hilfreich

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

DraftsmanCAD
Mitglied



Sehen Sie sich das Profil von DraftsmanCAD an!   Senden Sie eine Private Message an DraftsmanCAD  Schreiben Sie einen Gästebucheintrag für DraftsmanCAD

Beiträge: 10
Registriert: 08.12.2022

erstellt am: 01. Jun. 2023 16:07    Editieren oder löschen Sie diesen Beitrag!  <-- editieren / zitieren -->   Antwort mit Zitat in Fett Antwort mit kursivem Zitat    Unities abgeben: 1 Unity (wenig hilfreich, aber dennoch)2 Unities3 Unities4 Unities5 Unities6 Unities7 Unities8 Unities9 Unities10 Unities

Anzeige.:

Anzeige: (Infos zum Werbeplatz >>)

Darstellung des Themas zum Ausdrucken. Bitte dann die Druckfunktion des Browsers verwenden. | Suche nach Beiträgen

nächster neuerer Beitrag | nächster älterer Beitrag
Antwort erstellen


Diesen Beitrag mit Lesezeichen versehen ... | Nach anderen Beiträgen suchen | CAD.de-Newsletter

Administrative Optionen: Beitrag schliessen | Archivieren/Bewegen | Beitrag melden!

Fragen und Anregungen: Kritik-Forum | Neues aus der Community: Community-Forum

(c)2023 CAD.de | Impressum | Datenschutz