|
Hallo Jan,
ich habe das Quick-and-Dirty-Programm von gestern noch einmal angesehen und einige Verbesserungen eingefügt. Insbesondere wird die Hülle als Strich gezeichnet.
Sub GrahamHüllKurve()
'Die x-Koordinaten der einzuhüllenden Punktmenge seien in Spalte A,
'die y-Koordinaten in Spalte B jeweils ab Zeile 2 eingetragen.
'Während der Berechnung werden die Punkte umsortiert. Punkte, die zur
'Enveloppe gehören, werden blau, andere rot eingefärbt.
'Es wird eine Grafik mit den Punkten mit gleichen Farben ausgegeben.
'Damit eine geschlossene Kurve für die Enveloppe gezeichenet werden kann,
'wird der erste Punkt als letzter Enveloppenpunkt noch einmal eingefügt.
'Eine ev. vorhandene Verdoppelung wird zu Beginn beseitigt.
For Each s In ActiveSheet.Shapes ' ev. vorhandene Diagramme löschen
s.Delete
Next
lz = Cells(Rows.Count, 1).End(xlUp).Row 'Anzahl der Punkte
For i = 2 To lz 'ev. vorhandene Verdoppelung Ausgangspunkt löschen
If Cells(i, 1).Font.Color = vbRed Then Exit For
Next i
If Cells(i - 1, 1) = Cells(2, 1) And Cells(i - 1, 2) = Cells(2, 2) Then Rows(i - 1).Delete
If lz < 3 Then MsgBox "Zu wenig Punkte!": Exit Sub
Pi = 4 * Atn(1)
y_min = Cells(1, 2): m = 0
x_min = Application.WorksheetFunction.Min(ActiveSheet.Range(Cells(2, 1), Cells(lz, 1)))
y_min = Application.WorksheetFunction.Min(ActiveSheet.Range(Cells(2, 2), Cells(lz, 2)))
For i = 2 To lz
Cells(i, 3) = Cells(i, 1) - x_min
Cells(i, 4) = Cells(i, 2) - y_min
'alle Winkel nach Konstruktion < Pi
If Cells(i, 3) = 0 Then
Cells(i, 5) = Sgn(Cells(i, 4)) * Pi / 2
Else
Cells(i, 5) = Atn(Cells(i, 4) / Cells(i, 3))
End If
If Cells(i, 3) < 0 Then Cells(i, 5) = Cells(i, 5) + Pi
Next i
With ActiveSheet.Sort 'nach Winkel und y reduziert
.SortFields.Clear
.SortFields.Add Key:=Range(Cells(2, 5), Cells(lz, 5)), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SortFields.Add Key:=Range(Cells(2, 4), Cells(lz, 4)), _
SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
.SetRange Range(Cells(2, 1), Cells(lz, 5))
.Header = xlNo
.Apply
End With
a = lz + 1
If lz > 2 Then
For i = 3 To lz 'gleiche Winkel bestimmen und aussortieren
If Cells(i - 1, 5) = Cells(i, 5) Then
Cells(a, 1) = Cells(i, 1)
Cells(a, 2) = Cells(i, 2)
For j = 1 To 6: Cells(i, j) = "": Next j
a = a + 1
End If
Next i
End If
For i = a - 1 To 2 Step -1
If Cells(i, 1) = "" Then Rows(i).Delete
Next i
Do 'Algorithmus anwenden
w = 0
lz1 = Cells(Rows.Count, 3).End(xlUp).Row
a = lz + 1
For i = 2 To lz1 - 2
If (Cells(i + 1, 3) - Cells(i, 3)) * (Cells(i + 2, 4) - Cells(i, 4)) - _
(Cells(i + 2, 3) - Cells(i, 3)) * (Cells(i + 1, 4) - Cells(i, 4)) <= 0 Then
Cells(a, 1) = Cells(i + 1, 1)
Cells(a, 2) = Cells(i + 1, 2)
For j = 1 To 6: Cells(i + 1, j) = "": Next j
a = a + 1
w = 1
Exit For
End If
Next i
If w = 1 Then
For i = a - 1 To 2 Step -1
If Cells(i, 1) = "" Then Rows(i).Delete
Next i
End If
Loop Until w = 0
lz1 = Cells(Rows.Count, 3).End(xlUp).Row + 1 'Chart zeichnen
Rows(2).Copy
Rows(lz1).Insert Shift:=xlShiftDown
ActiveSheet.Columns("c:e").Delete
ActiveSheet.Shapes.AddChart(xlXYScatter, 150, 10, 500, 350).Select
With ActiveChart
.HasTitle = True
.ChartTitle.text = "Konvexe Hülle einer Punktmenge"
.SeriesCollection.NewSeries
With .SeriesCollection(1)
.XValues = Range(Cells(lz1 + 1, 1), Cells(lz + 1, 1))
.Values = Range(Cells(lz1 + 1, 2), Cells(lz + 1, 2))
.MarkerBackgroundColor = RGB(255, 0, 0)
.MarkerStyle = 2
.MarkerSize = 5
.Name = "Sonstige Punkte"
End With
Range(Cells(2, 1), Cells(lz1, 2)).Font.Color = vbBlue
If lz1 < lz Then
.SeriesCollection.NewSeries
With .SeriesCollection(2)
.XValues = Range(Cells(2, 1), Cells(lz1, 1))
.Values = Range(Cells(2, 2), Cells(lz1, 2))
.Border.ColorIndex = 41
.MarkerBackgroundColor = RGB(0, 0, 255)
.MarkerForegroundColor = RGB(0, 0, 255)
.MarkerStyle = 3
.MarkerSize = 8
.Name = "Enveloppe"
End With
Range(Cells(lz1 + 1, 1), Cells(lz + 1, 2)).Font.Color = vbRed
End If
If .SeriesCollection.Count > 2 Then .SeriesCollection(3).Delete
End With
End Sub
Frohe Osterm
Holger
|