---

Hallo,
ich grüble grad über folgendes:

ich habe eine funktion, die mir bei klicken auf ein segment einer geschlossenen polylinie die nr. des vertex zurückgibt.
Jetzt möchte zusätzlich noch eine parallele linie zum angeklickten vertex erstellen die innerhalb der geschlossenen polylinie gezeichnet wird. Das habe ich mir so vorgestellt:

1. Erstellen einer neuen linie mit gleichem startpunkt/endpunkt wie die des selektierten vertex
2. Versatz der linie zum mittelpunkt des polygons
3. Löschen der originalline

Leider schaffe ich es nicht, den versatz so zu steuern, dass die linie immer in richtung der mitte der geschlossenen polylinie bzw. des polygons versetzt wird. Je nach zeichnungsrichtung ist die linie innerhalb oder außerhalb (auch bei vorzeichenänderung). Hat da jemand eine idee?
lg, ritchie

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

---

Ja, du musst die mathematische Orientierung Richtung der PolyLinie bestimmen. Dann weist du wie rum die gezeichnet wurde und kannst enstprechend darauf reagieren. Also im Uhrzeigersinn oder gegen denselben. Kriegt man über die Fläche raus. Lach nicht, die können auch negativ sein 

Lieben Gruß
Thomas

Public Type POINT3D
  x As Double
  y As Double
  z As Double
End Type

' Return True if the POLYGON is oriented polyline_orientation_is_clockwise.
Public Function POLYGON_is_oriented_Clockwise(POLYGON_POINTs() As Point3d) As Boolean
    POLYGON_is_oriented_Clockwise = POLYGON_area_signed(POLYGON_POINTs) < 0
End Function

' Return the POLYGON's area
' Add the areas of the trapezoids defined by the
' POLYGON's edges dropped to the X-axis. When the
' program considers a bottom edge of a POLYGON, the
' calculation gives a negative area so the space
' between the POLYGON and the axis is subtracted,
' leaving the POLYGON's area. This method gives odd
' results for non-simple POLYGONs.
' The value will be negative if the polyogn is
' oriented Polyline_orientation_is_clockwise.
Public Function POLYGON_area_signed(POINTS() As Point3d) As Double
    Dim pt As Long
    Dim AREA As Double
    For CP = 0 To UBound(POINTS)
        nP = CP + 1
        If nP > UBound(POINTS) Then nP = 0
        AREA = AREA + 0.5 * (POINTS(nP).X - POINTS(CP).X) * (POINTS(nP).y + POINTS(CP).y)
    Next
    POLYGON_area_signed = AREA
End Function

------------------
Wer es nicht versucht, hat schon verlorn 
Und bei 3 Typos gibts den vierten gratis !
<<< not for sale !

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

---

Poste die Routine mal wenn du die fertig hast, sowas in der Art fehlt glaube ich noch in der Sammlung. 

------------------
Wer es nicht versucht, hat schon verlorn 
Und bei 3 Typos gibts den vierten gratis !
<<< not for sale !

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

---

hallo rexxitall,
welche werte übergebe ich mit dem aufruf von der Funktion  "POLYGON_is_oriented_Clockwise"? sind das ALLE Punkte des Polygons?
Wenn ja, wie ist dazu die Syntax? oder brauche ich da eine separate Funktion die alle Punkte des Polygons durchläuft und die variable POINT3D füllt und dann erst der Aufruf von "POLYGON_is_oriented_Clockwise" erfolgt?

Routine poste sobald es funktioniert.
lg, ritchie

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

---

Moin, ja die Routine benötigt alle Polygonpunkte als Array. Sie berechnet ja die Fläche nach Gauß 

Lieben Gruß
Thomas

Function POINTS_FROM_ENTITY(ByRef POINTS() As Point3d, entity As AcadEntity, Optional center As Boolean = True, Optional infohandle As Boolean = True, Optional SUBARCDIVIDER As Long = 0) As Long
    Dim TTEXT As ACADTEXT
    Dim MTEXT As AcadMText
    Dim acircle As AcadCircle
    Dim aarc As AcadArc
    Dim face As Object
    Dim ppoint As AcadPoint
    Dim spline As AcadSpline
    Dim BLOCKREF As AcadBlockReference
    Dim v As Variant
    Dim p As Point3d
    Dim PP() As Point3d
    Dim S As String
    Dim linefound As Boolean
    Dim N As Long
    Dim radius As Double
    If entity Is Nothing Then Exit Function
   
    POINTS_FROM_ENTITY = 0
    ''debug.print  entity.objectname
   
    Dim Lastpoints As Long
    On Error Resume Next
    newpointstart = UBound(POINTS)
    On Error GoTo 0
    Select Case LCase(entity.objectname)
        Case "acdbtext"
            Set TTEXT = entity
            v = TTEXT.insertionPoint
            p = V2P3D(v)
            S = TTEXT.TEXTSTRING
            S = REPLACE(S, ",", ".")
            If Len(S) > 4 Then
                If p.z = 0 And IsNumeric(S) = True Then p.z = val(S)
                p.INFO = S
                Call POINTS_ADD_3D(POINTS(), p)
                N = N + 1
            Else
                entity.COLOR = acYellow
            End If
        Case "acdbmtext"
            Set MTEXT = entity
            v = MTEXT.insertionPoint
            p = V2P3D(v)
            S = MTEXT.TEXTSTRING
            S = REPLACE(S, ",", ".")
            If p.z = 0 And IsNumeric(S) = True Then p.z = val(S)
            p.INFO = S
            N = N + 1
            Call POINTS_ADD_3D(POINTS(), p)
        Case "acdbpoint"
            Set ppoint = entity
            v = ppoint.COORDINATES
            p = V2P3D(v)
            N = N + 1
            Call POINTS_ADD_3D(POINTS(), p)
   
        Case "acdbcircle"
            Set acircle = entity
            v = acircle.center
            p = V2P3D(v)

            Call POINTS_ADD_3D(POINTS(), p)
            N = N + 1

        Case "acdface", "aeccdbface", "acdbface"
            Set face = entity
            If face_get_POINTs(POINTS, entity) Then
                N = N + UBound(POINTS)
            End If

        Case "acdbhatch"
            'Debug.Print "points from hatch is not supported"
       
        Case "acdbarc"
   
   
            Set aarc = entity
            v = aarc.center
            MP = aarc.center
            radius = aarc.radius
           
           
            Dim M As Point3d
            M.X = aarc.center(0)
            M.y = aarc.center(1)
            M.z = aarc.center(2)
           
           
            Dim RP As Point3d
            Dim a As Double
            Dim aa As Double
            If KP = 0 Then KP = SUBARCDIVIDER + 1
            If KP = 0 Then KP = ARCDIVIDER + 1
            If KP = 0 Then KP = 3
            a = (aarc.endAngle - aarc.startAngle) / KP
            ' Debug.Print R2D(aarc.endAngle), R2D(aarc.startAngle), R2D(aarc.endAngle - aarc.startAngle), R2D(A)
            aa = aarc.startAngle
            Dim sp As Point3d
            sp.X = aarc.startPoint(0)
            sp.y = aarc.startPoint(1)
            X = sp.X - M.X
            y = sp.y - M.y
            r = aarc.radius
            Dim aaa As Double
            aa = aarc.startAngle - a
         
            For i = 0 To KP
                aa = aa + a
                Debug.Print
               
                RP.X = 0
                RP.y = 0
                RP.X = r * Cos(aa) + M.X '- Y * sIn(aa)
                RP.y = r * sin(aa) + M.y '+ Y * Cos(aa)
               
                ' RP.X = RP.X * Cos(aaa) - RP.Y * sIn(aaa)
                ' RP.Y = RP.X * sIn(aaa) + RP.Y * Cos(aaa)
               
               
                RP.z = aarc.center(2)
                'Call DBGBALLP3D(RP)
                Call POINTS_ADD_3D(POINTS(), RP)
               

            Next
            N = KP
         
           
            If 1 = 2 Then
     
     
     
           
                KILLBALL
                Dim PSP As Point3d

                PSP.X = v(0)
                PSP.y = v(1)
                PSP.z = v(2)

                Call DBGBALLP3D(PSP)

                Dim PHI(1) As Double
                Dim theta(1) As Double
                Dim AT As Double
                AT = aarc.TotalAngle

                Dim pt As Point3d
                'sphere parametric form
                'x = xc + r * cos(theta) * cos(phi)
                'y = yc + r * cos(theta) * sin(phi)
                'z = zc + r * sin(theta)
                Dim ctheta As Double
                For i = 0 To 1
 
 
                    theta(i) = ArcSin((PP(i).z - PSP.z) / radius)
                    ctheta = Cos(theta(i))
                    If ctheta > 0 Then
                        PHI(i) = ArcSin((PP(i).y - PSP.y) / radius / ctheta)
                        PHI(i) = ArcCos((PP(i).X - PSP.X) / radius / ctheta)
                    End If
                    'debug.print  PHI(I) * 180 / Pi, Theta(I) * 180 / Pi
 
                    pt.X = PSP.X + radius * Cos(theta(i)) * Cos(PHI(i))
                    pt.y = PSP.y + radius * Cos(theta(i)) * sin(PHI(i))
                    pt.z = PSP.z + radius * sin(theta(i))

                    Call DBGBALLP3D(pt)
 
                Next
                applicaTION.UPDATE
                'debug.print  (PHI(1) - PHI(0)) * 180 / Pi, (Theta(1) - Theta(0)) * 180 / Pi
                Dim PN As Point3d
   
                Dim THETATOTAL As Double
                Dim PHITOTAL As Double

                PHITOTAL = PHI(1) - PHI(0)
                THETATOTAL = theta(1) - theta(0)

                Dim pphi As Double
                Dim ptheta As Double
   
                Dim DP As Double
                Dim dt As Double
                ReDim PP(N)
                N = 6

                pphi = PHITOTAL / (N)
                ptheta = THETATOTAL / (N)

                DP = PHI(0)
                dt = theta(0)

                For i = 0 To N
                    'debug.print  Sin(DT)
                    pt.X = PSP.X + radius * Cos(dt) * Cos(DP)
                    pt.y = PSP.y + radius * Cos(dt) * sin(DP)

                    On Error Resume Next
                    pt.z = PSP.z + Sqr(radius * radius - ((radius * Cos(dt) * Cos(DP)) ^ 2 + (radius * Cos(dt) * sin(DP)) ^ 2))

                    'r2 = X2 + Y2 + z2

                    'PT.z = PSP.z + RADIUS * Sin(dt)

                    DP = DP + pphi
                    dt = dt + ptheta
                    Call DBGBALLP3D(pt)
                    Call POINTS_ADD_3D(POINTS(), pt)
                Next
   
            End If
   
        Case "acdbblockreference"
            Set BLOCKREF = entity
            v = BLOCKREF.insertionPoint
            p = V2P3D(v)

            Call POINTS_ADD_3D(POINTS(), p)
            N = N + 1

            ' Case "acdbsection"

        Case Else
            linefound = False
            If (InStr(LCase(entity.objectname), "line") > 0) And (InStr(LCase(entity.objectname), "xline") = 0) Then linefound = True
            If (InStr(LCase(entity.objectname), "lead") > 0) Then linefound = True
            If (InStr(LCase(entity.objectname), "face") > 0) Then linefound = True
            If (InStr(LCase(entity.objectname), "section") > 0) Then linefound = True
            If linefound Then
                N = N + POINTS_FROM_POLYLINE(PP(), entity)
                If N > 0 Then
                    On Error Resume Next
                    For i = LBound(PP) To UBound(PP)
                        Call POINTS_ADD_3D(POINTS(), PP(i))
                    Next
                End If
            End If
           
            If InStr(LCase(entity.objectname), "xline") > 0 Then
                Dim xl As AcadXline
                Set xl = entity
                ReDim POINTS(1)
                N = 2
                POINTS(0).X = xl.basePoint(0)
                POINTS(0).y = xl.basePoint(1)
                POINTS(0).z = xl.basePoint(2)
           
                POINTS(1).X = xl.DirectionVector(0) + POINTS(0).X
                POINTS(1).y = xl.DirectionVector(1) + POINTS(0).y
                POINTS(1).z = xl.DirectionVector(2) + POINTS(0).z
           
            End If
           
    End Select
   
   
    If N <> 0 Then
        If infohandle = True Then
            For i = Lastpoints + 1 To UBound(POINTS)
                POINTS(i).INFO = entity.HANDLE
            Next
        End If
   
    End If
   
    POINTS_FROM_ENTITY = N
End Function

Function POINTS_FROM_POLYLINE(ByRef POINTS() As Point3d, entity As AcadEntity) As Long
    Dim v As Variant
    Dim i As Long
    Dim j As Long

    Dim POINTCOUNT As Long
    Dim polylw As AcadLWPolyline
    Dim POLY3D As Acad3DPolyline
    Dim Poly2D As AcadLWPolyline
    Dim polym As AcadMLine
   

    Dim polyAC As AcadPolyline
    Dim line As acadline
    Dim spline As AcadSpline
    Dim LEADER As AcadLeader
    Dim MLEADER As ACADOBJECT 'AcadMleader
    Dim face As Acad3DFace
    Dim closed As Boolean

    Dim S As String
   
    DoEvents
   
    POINTS_FROM_POLYLINE = -1
    S = LCase(entity.objectname)
    j = 0
    closed = False
    If entity Is Nothing Then Exit Function

    Select Case S

        Case "acdbline"
            Set line = entity
            ReDim POINTS(1)
            POINTS(0).X = line.startPoint(0)
            POINTS(0).y = line.startPoint(1)
            POINTS(0).z = line.startPoint(2)

            POINTS(1).X = line.endPoint(0)
            POINTS(1).y = line.endPoint(1)
            POINTS(1).z = line.endPoint(2)
            POINTCOUNT = 1
           
        Case "acdbpolyline"
            v = entity.COORDINATES

            POINTCOUNT = ((UBound(v) + 1) / 2) - 1
            Erase POINTS
            ReDim POINTS(POINTCOUNT)
            ''debug.print  pointcount
            Set polylw = entity
            closed = polylw.closed
            For i = 0 To POINTCOUNT

                POINTS(i).X = v(j): j = j + 1
                POINTS(i).y = v(j): j = j + 1
                POINTS(i).z = polylw.ELEVATION
                POINTS(i).B = polylw.GetBulge(i)
                'POINTS(i).z = polylw.COORDINATES(j): j = j + 1
                '            points(i).z = polyLW.coordinates(J): J = J + 1
            Next
 
        Case "acdb3dpolyline"

            Set Acad3DPolyline = entity
            closed = Acad3DPolyline.closed
            v = entity.COORDINATES
           
            ' pointCount = ((UBound(v) + 1) / 2) - 1
            POINTCOUNT = ((UBound(v) + 1) / 3) - 1
            ReDim POINTS(POINTCOUNT)
            ''debug.print  pointcount
            For i = 0 To POINTCOUNT
                POINTS(i).X = v(j): j = j + 1
                POINTS(i).y = v(j): j = j + 1
                POINTS(i).z = v(j): j = j + 1
                POINTS(i).B = 0
            Next
            POINTS_FROM_POLYLINE = POINTCOUNT

        Case "acdbface"

            Set face = entity
            closed = False
            v = face.COORDINATES
            ' pointCount = ((UBound(v) + 1) / 2) - 1
            POINTCOUNT = ((UBound(v) + 1) / 3) - 1
            ReDim POINTS(POINTCOUNT)
            ''debug.print  pointcount
            For i = 0 To POINTCOUNT
                POINTS(i).X = face.COORDINATES(j): j = j + 1
                POINTS(i).y = face.COORDINATES(j): j = j + 1
                POINTS(i).z = face.COORDINATES(j): j = j + 1
            Next
            POINTS_FROM_POLYLINE = POINTCOUNT

   

        Case "acdblwpolyline"

            Set polylw = entity
            closed = polylw.closed
            v = polylw.COORDINATES
            POINTCOUNT = ((UBound(v) + 1) / 2) - 1
            ReDim POINTS(POINTCOUNT)
            ''debug.print  pointcount
            For i = 0 To POINTCOUNT
                POINTS(i).X = v(j): j = j + 1
                POINTS(i).y = v(j): j = j + 1
                POINTS(i).z = polylw.ELEVATION
                POINTS(i).B = polylw.GetBulge(i)
            Next

            POINTS_FROM_POLYLINE = POINTCOUNT

       
 
        Case "acdb2dpolyline"

            Set polyAC = entity
            closed = polyAC.closed
            v = entity.COORDINATES
            ' pointCount = ((UBound(v) + 1) / 2) - 1
            POINTCOUNT = ((UBound(v) + 1) / 3) - 1
            ReDim POINTS(POINTCOUNT)
            ''debug.print  pointcount
            For i = 0 To POINTCOUNT
                POINTS(i).B = polyAC.GetBulge(i)
                POINTS(i).X = v(j): j = j + 1
                POINTS(i).y = v(j): j = j + 1
                POINTS(i).z = v(j): j = j + 1
                POINTS(i).z = polyAC.ELEVATION
            Next
            POINTS_FROM_POLYLINE = POINTCOUNT
 
     
        Case "acdbmline"
            v = entity.COORDINATES

            POINTCOUNT = ((UBound(v) + 1) / 3) - 1
            ReDim POINTS(POINTCOUNT)
            ''debug.print  pointcount
            Set polym = entity
               
            ReDim POINTS(POINTCOUNT)
            ''debug.print  pointcount
            For i = 0 To POINTCOUNT
                POINTS(i).X = v(j): j = j + 1
                POINTS(i).y = v(j): j = j + 1
                POINTS(i).z = v(j): j = j + 1
               
            Next

        Case "acdbleader"
            v = entity.COORDINATES

            POINTCOUNT = ((UBound(v) + 1) / 3) - 1
            ReDim POINTS(POINTCOUNT)
            'Set leader = entity
               
            ReDim POINTS(POINTCOUNT)
 
            For i = 0 To POINTCOUNT
                POINTS(i).X = v(j): j = j + 1
                POINTS(i).y = v(j): j = j + 1
                POINTS(i).z = v(j): j = j + 1
            Next

        Case "_acdbmleader"
            Dim MLEAD As AcadMleader
            Set MLEAD = entity
            'V = MLEAD.COORDINATES

            POINTCOUNT = ((UBound(v) + 1) / 3) - 1
            ReDim POINTS(POINTCOUNT)
            'Set leader = entity
               
            ReDim POINTS(POINTCOUNT)
 
            For i = 0 To POINTCOUNT
                POINTS(i).X = v(j): j = j + 1
                POINTS(i).y = v(j): j = j + 1
                POINTS(i).z = v(j): j = j + 1
            Next

        Case "acdb3dpolyline"
            Set POLY3D = entity
            closed = POLY3D.closed
            v = POLY3D.COORDINATES
            POINTCOUNT = ((UBound(v) + 1) / 3) - 1
            ReDim POINTS(POINTCOUNT)
            ''debug.print  pointcount
            For i = 0 To POINTCOUNT
                POINTS(i).X = v(j): j = j + 1
                POINTS(i).y = v(j): j = j + 1
                POINTS(i).z = v(j): j = j + 1
            Next
     
        Case "acdbspline"
            Set spline = entity
     
            spline.SplineMethod = acFit
            v = spline.fitPoints
            POINTCOUNT = ((UBound(v) + 1) / 3) - 1
            ReDim POINTS(POINTCOUNT)

            For i = 0 To POINTCOUNT
                POINTS(i).X = v(j): j = j + 1
                POINTS(i).y = v(j): j = j + 1
                POINTS(i).z = v(j): j = j + 1
            Next
       

        Case "acdbsection"
            Dim SECT As AcadSection
            Set SECT = entity
            closed = False
           
            POINTCOUNT = SECT.NumVertices - 1
           
           
           
           
           
           
           
            ReDim POINTS(POINTCOUNT)
            ''debug.print  pointcount
            For i = 0 To POINTCOUNT
                v = SECT.coordinate(i)
                POINTS(i).X = v(0)
                POINTS(i).y = v(1)
                POINTS(i).z = v(2)
            Next
            closed = False

    End Select
   
    If closed Then
        POINTCOUNT = POINTCOUNT + 1
        ReDim Preserve POINTS(POINTCOUNT)
        POINTS(POINTCOUNT) = POINTS(0)
    End If
   
    POINTS_FROM_POLYLINE = POINTCOUNT + 1
End Function

Sub POINTS_add(POINTS() As Point3d, ByVal X As Double, ByVal y As Double, Optional ByVal z As Double = 0, Optional INFO As String, Optional BULGE As Double)
    Dim C As Long
    On Error Resume Next
    ERR.CLEAR
    ubtest = UBound(POINTS)
    If ERR.NUMBER <> 0 Then
        ReDim POINTS(0)
    Else
        C = UBound(POINTS) + 1
    End If
    If POINTS(0).X <> NAN Then
        ReDim Preserve POINTS(0 To C)
        POINTS(C).X = X
        POINTS(C).y = y
        POINTS(C).z = z
        POINTS(C).INFO = INFO
        POINTS(C).B = BULGE
       
    Else
        POINTS(0).X = X
        POINTS(0).y = y
        POINTS(0).z = z
        POINTS(0).B = BULGE
    End If
End Sub

------------------
Wer es nicht versucht, hat schon verlorn 
Und bei 3 Typos gibts den vierten gratis !
<<< not for sale !

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

---

Ah, kleiner Fallstrick.
Du solltest mit

ERASE(POINTS)

das Array für jede Polygonlinie zunächst zurücksetzen. Diese Routinen "sammeln" Punkte. Z.B. wenn der Vermesser mal wieder nur Texte in die Zeichnung gesetzt hat und davon träumt, das man damit was anfängt.

For each entity in thisdrawing.pickfirstselectionset....
..
Ergibt also EIN Array mit allen Textkoodrinaten um da anschließend Blöcke mit Koordinatenangaben rein zu setzen etc.

Deswegen setzen diese Routinen das Array *nicht* selbst zurück.

Lieben Gruß
Thomas

------------------
Wer es nicht versucht, hat schon verlorn 
Und bei 3 Typos gibts den vierten gratis !
<<< not for sale !

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