---

Hallo,
Noch mal eine Frage, die schon mal in lisp beantwortet wurde.
Ich würde die Lösung aber in VBA in mein vorhandenes Projekt einbinden wollen.
Kann man an einer Polylinie zwei Stationen abgreifen(picken) und die Länge dazwischen weiterverarbeiten?
Vielen Dank für Eure Hilfe.

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

---

Ich hab mir so ein kleines Tool geschrieben, dafür brauchst du aber AcadX.arx oder VLAX.cls und Curve.cls, brauchst einfach nur in diesem Forum suchen. Es wird einiges nicht bei dir funktionieren, ich habe einige Funktionen nicht drangehängt, ebenso die Benutzereingabe die ich von Bernd Cuder übernommen habe. Darum geht es aber in dem Beispiel nicht.
Wenn du AcadX.arx verwendest, gilt 'NEU, verwendest du allerdings die VLAX- und CURVE-Klassenmodule, dann 'ALT.

Code:

---

Public Sub LaengeExtend()

'ALT    Dim Kurve As New Curve        ' Neues Klassenmodul Curve
'NEU
    Dim XApp As AcadXApplication    'neue AcadX Application
    Dim Kurve As IAcadXCurve        ' Neues Klassenmodul Curve
'---
   
    Dim keywordList As String  ' Liste an Schlüsselwörtern
   
    Dim Elem As AcadEntity      ' zu messendes Objekt: "Kurve" (Linie, PLinie, LWPlinie, Spline, Bogen, Kreis, Ellipse)
    Dim WPunkt As Variant      ' Punkt mit dem "Kurve" ausgewählt wurde (muß nicht auf der "Kurve" liegen)
    Dim APunkt As Variant      ' gezeigter Anfangspunkt (muß nicht auf der "Kurve" liegen)
    Dim ANPunkt As Variant      ' Anfangspunkt auf "Kurve" (der näheste Punkt auf der "Kurve" zu APunkt)
    Dim ANPunktDist As Double  ' Abstand auf der "Kurve" zu ANPunkt
    Dim EPunkt As Variant      ' gezeigter Endpunkt (muß nicht auf der "Kurve" liegen)
    Dim ENPunkt As Variant      ' Anfangspunkt auf "Kurve" (der näheste Punkt auf der "Kurve" zu EPunkt)
    Dim ENPunktDist As Double  ' Abstand auf der "Kurve" zu ENPunkt
    Dim SLaenge As Double      ' Segmentlänge
   
    Dim Nachkomma As Long      ' Anzahl dr Nachkommastellen
   
    Nachkomma = ThisDrawing.GetVariable("LUPREC")
   
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'      BEGINN BENUTZEREINGABE
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
RETRY:
    On Error GoTo ENDE1
    GetEntityEx(Elem, WPunkt, vbCr & "Objekt wählen: ")
   
    If Err <> 0 Then Exit Sub      ' es wurde mit "RETURN" oder "ESC" abgebrochen

'NEU
    Set XApp = New AcadXApplication
    If XApp.IsCurve(Elem) = False Then GoTo RETRY
    Set Kurve = XApp.GetCurve(Elem)
   
'ALT
'    On Error Resume Next
'    Set Kurve.Entity = Elem
'    If Err Then
'        Err.Clear
'        ThisDrawing.Utility.Prompt "Kein gültiges Objekt" & vbCrLf
'        GoTo RETRY
'    End If
   
    Elem.Highlight (True)
   
    GoTo ZweiterPunkt
   
    On Error GoTo ENDE
ErsterPunkt:
    APunkt = ThisDrawing.Utility.GetPoint(, vbCr & "Ersten Punkt angeben: ")
    ANPunkt = Kurve.GetClosestPointTo(APunkt)
    ANPunktDist = Kurve.GetDistanceAtPoint(ANPunkt)
       
ZweiterPunkt:
   
    Do
       
        Userinput 2, "Erster Punkt bei " & funPunkt(Format(ANPunktDist, "0." & String(Nachkomma, "0"))) & ", zweiten Punkt oder", 128, "Ersten", "Ersten", Nachtext:=" Punkt angeben", KeyYesNo:=False
       
        Select Case User.Antwort
            Case "G"        'Eingabe war Distance
                EPunkt = User.punkt
            Case "K"        'Eingabe war Schlüsselwort
                Select Case Format(ThisDrawing.Utility.GetInput, ">")
                    Case "ERSTEN"
                        GoTo ErsterPunkt
                    Case Else
                        GoTo ENDE
                End Select
            Case "A"        'Eingabe war ESC
                GoTo ENDE
            Case "L"        'Eingabe war Leereingabe (SPACE, RETURN)
                GoTo ErsterPunkt
            Case "B"        'Eingabe war nicht transparenter Befehl
                GoTo TRANS_BEFEHL
        End Select
       
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'        ENDE BENUTZEREINGABE
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
        ENPunkt = Kurve.GetClosestPointTo(EPunkt)
       
        On Error GoTo ENDE
        ENPunktDist = Kurve.GetDistanceAtPoint(ENPunkt)
       
        SLaenge = Abs(ANPunktDist - ENPunktDist)
        ThisDrawing.Utility.Prompt vbCr & "Länge: " & funPunkt(Format(SLaenge, "0." & String(Nachkomma, "0")))
    Loop

ENDE:
    Elem.Highlight (False)
       
ENDE1:
    Exit Sub

TRANS_BEFEHL:
    ThisDrawing.SendCommand User.Befehl
    GoTo ENDE
     
End Sub

Public Sub GetEntityEx(ent As Object, pickedPoint, Optional Prompt)

    On Error Resume Next
StartLoop:
    ActiveDocument.Utility.GetEntity ent, pickedPoint, Prompt
    If Err Then
        If ActiveDocument.GetVariable("errno") = 7 Then
            Err.Clear
            GoTo StartLoop
        Else
            Err.Raise vbObjectError + 5, , "User cancelled operation"
        End If
    End If

End Sub

---

Noch Fragen?

------------------
Roland

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

---

Mit folgendem Beispielcode kannst Du die Länge eines LWPolylinienabschnittes zwischen zwei gewählten Punkten ermitteln. Die Schwierigkeit besteht dabei nur in den Kurvenabschnitten der Polylinie. Hierfür mußt Du aus den Ausbuchtungswerten die Bogenlänge berechnen (Funktion GetArcLength). Die Länge von Punkt nach Punkt dürfte hingegen relativ einfach sein. Im Prinzip dürfte der Code aber so funktionieren (Hoffe ich).

Public Sub GetPolyLength()
Dim Object As Object, lwPoly As AcadLWPolyline
Dim IsFirst As Boolean, pBulge As Double
On Error Resume Next
fPoint = Utility.GetPoint(, "von Punkt:")
If IsEmpty(fPoint) = True Then Exit Sub
tPoint = Utility.GetPoint(, "nach Punkt:")
If IsEmpty(tPoint) = True Then Exit Sub
Utility.GetEntity Object, PickedPoint, "Polylinie wählen"
If Object Is Nothing Then Exit Sub
Select Case TypeName(Object)
  Case "IAcadLWPolyline"
      Set lwPoly = Object
      For i = 0 To ((UBound(lwPoly.Coordinates) + 1) / 2) - 1
        If GetDistance(tPoint, lwPoly.Coordinate(i)) <= 0.001 Then
            If IsFirst = True Then
              If pBulge = 0 Then
                  gDist = gDist + GetDistance(LastPt, lwPoly.Coordinate(i))
                  LastPt = lwPoly.Coordinate(i)
              Else
                  gDist = gDist + GetArcLength(LastPt, lwPoly.Coordinate(i), pBulge)
                  LastPt = lwPoly.Coordinate(i)
              End If
              Exit For
            Else
              IsFirst = True
              LastPt = lwPoly.Coordinate(i)
              pBulge = lwPoly.GetBulge(i)
            End If
        ElseIf GetDistance(fPoint, lwPoly.Coordinate(i)) <= 0.001 Then
            If IsFirst = True Then
              If pBulge = 0 Then
                  gDist = gDist + GetDistance(LastPt, lwPoly.Coordinate(i))
                  LastPt = lwPoly.Coordinate(i)
              Else
                  gDist = gDist + GetArcLength(LastPt, lwPoly.Coordinate(i), pBulge)
                  LastPt = lwPoly.Coordinate(i)
              End If
              Exit For
            Else
              IsFirst = True
              LastPt = lwPoly.Coordinate(i)
              pBulge = lwPoly.GetBulge(i)
            End If
        ElseIf IsFirst = True Then
            If pBulge = 0 Then
              gDist = gDist + GetDistance(LastPt, lwPoly.Coordinate(i))
              LastPt = lwPoly.Coordinate(i)
            Else
              gDist = gDist + GetArcLength(LastPt, lwPoly.Coordinate(i), pBulge)
              LastPt = lwPoly.Coordinate(i)
            End If
            pBulge = lwPoly.GetBulge(i)
        End If
      Next
End Select
MsgBox "Länge des Abschnittes: " & Utility.RealToString(gDist, acDefaultUnits, 4)
End Sub

Public Function GetArcLength(fPoint, tPoint, Bulge) As Double
Const PI = 3.14159265358979
On Error Resume Next
h = (GetDistance(fPoint, tPoint) / 2) * Bulge
rRadius = (GetDistance(fPoint, tPoint) ^ 2 / (8 * h)) + (h / 2)
alpha = asin((GetDistance(fPoint, tPoint) / 2) / rRadius) * 2
If Abs(Bulge) > 1 Then alpha = 2 * PI - Abs(alpha)
GetArcLength = Abs(rRadius * alpha)
End Function

Public Function asin(Angle) As Double
On Error Resume Next
asin = Atn(Angle / Sqr(-Angle * Angle + 1))
End Function

Public Function GetDistance(fPoint, tPoint) As Double
On Error Resume Next
GetDistance = Sqr((fPoint(0) - tPoint(0)) ^ 2 + (fPoint(1) - tPoint(1)) ^ 2)
End Function

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

---

Hallo,
Herzlichen Dank. wirklich gut. Es geht bei "eckigen" Polylinien echt gut. Bei abgerundeten Abschnitten nicht immer. Vielleich bekomme ich es noch raus
Danke. Tschau

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