Wann ist ein Shape-Freeform eine Fläche?

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

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

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

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!

Beliebteste Forumthreads (12 Monate)

Wann ist ein Shape-Freeform eine Fläche?

3 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

3
Beiträge zum Forumthread

Beiträge zu diesem Forumthread