Wann ist ein Shape-Freeform eine Fläche?

Bewerten Sie hier bitte das Excel-Portal

Der kurze Weg zum Ziel: Auftragsprogrammierung

Wann ist ein Shape-Freeform eine Fläche?

Wann ist ein Shape-Freeform eine Fläche? von StonY vom 22.09.2019 23:26:35

AW: Wann ist ein Shape-Freeform eine Fläche? - von StonY am 23.09.2019 20:35:11

AW: Wann ist ein Shape-Freeform eine Fläche? - von StonY am 25.09.2019 13:18:30

AW: Wann ist ein Shape-Freeform eine Fläche? - von StonY am 26.09.2019 23:45:19

Betrifft: Wann ist ein Shape-Freeform eine Fläche? von: StonY
Geschrieben am: 22.09.2019 23:26:35

Guten Abend,

könnt ihr mir bitte bei folgendem Problem helfen?

Ich habe diverse Punkte per VBA zu Linienzügen konvertiert.
So ungefähr lautet mein Code:

Function FreieForm
Dim k As Variant
With ActiveSheet.Shapes.BuildFreeform(msoEditingAuto, pL(1, 1), pL(1, 2))
For k = 2 To aP
.AddNodes msoSegmentLine, msoEditingAuto, pL(k, 1), pL(k, 2)
Next k
.ConvertToShape.Name = "HalloFormName"
End With
'Wobei pL ein Array mit (k,1)=x und (k,2)=y Werten und aP die Anzahl der Punkte ist.
End Function

Darunter sind sowohl Linienzüge, als auch geschlossene Flächen.

Wenn ich später auf dem Tabellenblatt die FreeForm (also eine Art Polylinie) in einzelne Linien auflösen möchte, geht mir bei nachfolgender Funktion die Info einer Fläche verloren.

Mit Shapes.Nodes.Count liste ich zwar alle Punkte auf, erhalte aber als letzten Punkt nicht den Punktwert vom Ersten Punkt.

Sub ListNodesCoords_alle() 'alle Polilinien einlesen
Dim r As Long
r = 0
Dim ptsArr, i As Long, x As Double, y As Double, nc As Long
Dim ff As Shape
nf = Tabelle1.Shapes.Count
For k = 1 To nf
Set ff = Tabelle1.Shapes(k)
nc = ff.Nodes.Count
    For i = 1 To nc
    If i = 1 Then r = r + 1
        With ff.Nodes
            ptsArr = .Item(i).Points
            x = ptsArr(1, 1)
            y = ptsArr(1, 2)
            Cells(r, 1) = x
            Cells(r, 2) = y
            r = r + 1
        End With
    Next i
Next k
End Sub

Wie finde ich heraus, ob es ein Linienzug, oder eine geschlossene Fläche ist?

Es würde mir reichen, wenn über eine Abfrage der Attribute dies erkennbar wäre.
Dann würde ich bei einer Fläche einfach als letzten Punkt den allerersten Punktwert hinzufügen.

Vielen Dank für eure Hilfe!

StonY

Betrifft: AW: Wann ist ein Shape-Freeform eine Fläche? von: StonY
Geschrieben am: 23.09.2019 20:35:11

Hallo zusammen,
vielleicht hilft es euch, wenn ich euch noch etwas mehr Herleitung gebe.

mit folgendem Beispielcode werden in der Tabelle1 zwei Polylinien erzeugt.

Sub ZeichneTestPolylinien()

Dim PBuch(1000, 2) As Variant '(x,y)
Dim AnzLinP As Variant 'Anzahl Punkte der Polylinie
Dim z As String
Dim w As Variant

PBuch(1, 1) = 10
PBuch(1, 2) = 20

PBuch(2, 1) = 100
PBuch(2, 2) = 80

PBuch(3, 1) = 100
PBuch(3, 2) = 320

PBuch(4, 1) = 10
PBuch(4, 2) = 30

AnzLinP = 4 'Anzahl Punkte
w = "Hallo10" 'Liniennummer
col = 1 'Linie mit beidseitigem offenen Ende
z = ArrayZeichnen(PBuch(), AnzLinP, w, col)



PBuch(1, 1) = 110
PBuch(1, 2) = 120

PBuch(2, 1) = 200
PBuch(2, 2) = 180

PBuch(3, 1) = 200
PBuch(3, 2) = 300

PBuch(4, 1) = 110
PBuch(4, 2) = 120

AnzLinP = 4 'Anzahl Punkte
w = "Hallo11" 'Liniennummer
col = 2 'Fläche
z = ArrayZeichnen(PBuch(), AnzLinP, w, col)

End Sub

Function ArrayZeichnen(ByRef pL() As Variant, ByVal aP As Variant, ByRef w As Variant, ByVal _
col As Byte)
Dim v As Double
Dim k As Variant

    With ActiveSheet.Shapes.BuildFreeform(msoEditingAuto, pL(1, 1), pL(1, 2))
    For k = 2 To aP
        .AddNodes msoSegmentLine, msoEditingAuto, pL(k, 1), pL(k, 2)
    Next k
        .ConvertToShape.Name = w
    End With
If col = 1 Then ActiveSheet.Shapes(w).Line.ForeColor.RGB = RGB(160, 255, 80)
If col = 2 Then ActiveSheet.Shapes(w).Line.ForeColor.RGB = RGB(80, 160, 255)
ActiveSheet.Shapes(w).Line.Weight = 5
ActiveSheet.Shapes(w).Line.DashStyle = msoLineSolid


If col = 2 Then 'Fläche, Typ X
If pL(1, 1) = pL(aP, 1) Then
If pL(1, 2) = pL(aP, 2) Then
ActiveSheet.Shapes(w).Fill.ForeColor.RGB = RGB(255, 0, 0)
ActiveSheet.Shapes(w).Fill.Transparency = 0.7
End If
End If
End If

End Function

und mit folgendem Code möchte ich das wieder rückgängig machen.
Wo liegt da mein Problem, dass da eine Linie gelöscht wird?

Sub PolyErsetzen() 'alle Polilinien einlesen
'Dieses Tool malt die Polylinien nach, und löscht diese danach.
Dim myShape As Shape
Dim nc As Long
Dim i As Long
Dim x As Double
Dim y As Double
Dim X2 As Double
Dim Y2 As Double

Dim ptsArr
Dim Breite As Variant

Breite = 5
On Error GoTo ende
    For Each myShape In ActiveSheet.Shapes
    nc = myShape.Nodes.Count
    For i = 1 To nc
        With myShape.Nodes
            If i = 1 Then
            ptsArr = .Item(i).Points
            X2 = ptsArr(1, 1)
            Y2 = ptsArr(1, 2)
            Else
            x = X2
            y = Y2
            ptsArr = .Item(i).Points
            X2 = ptsArr(1, 1)
            Y2 = ptsArr(1, 2)
            With ActiveSheet.Shapes.AddLine(x, y, X2, Y2).Line
            .DashStyle = msoLineSolid
            .Weight = Breite
            .ForeColor.RGB = RGB(255, 100, 0)
            End With
            End If
        End With
    Next i
    If myShape.Type = 5 Then myShape.Delete
    Next myShape
    Exit Sub
ende:
    Exit Sub
End Sub

Vielen Dank für euren Support!

Betrifft: AW: Wann ist ein Shape-Freeform eine Fläche? von: StonY
Geschrieben am: 25.09.2019 13:18:30

Schöner Mittag zusammen,

das scheint eine schwierige Frage zu sein.
Gibt es überhaupt eine Lösung dazu?

Vielen Dank für eure Hilfe.

Liebe Grüsse, Stony

Betrifft: AW: Wann ist ein Shape-Freeform eine Fläche? von: StonY
Geschrieben am: 26.09.2019 23:45:19

Guten Abend zusammen,

gerne frage ich, ob ihr mein Problem lösen könnt.
Wie ist eure Einschätzung, lösbar oder muss ich einen anderen Workaround machen?

Danke für eure Hilfe!
Gruss StonY