Microsoft Excel

Herbers Excel/VBA-Archiv

Wann ist ein Shape-Freeform eine Fläche?


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


Beiträge aus dem Excel-Forum zum Thema "Wann ist ein Shape-Freeform eine Fläche?"