AW: verschiedene Kreise prüfen
14.05.2024 17:02:28
UweD
Hallo nochmal
Sicher kann man die automatisch setzen (hab ich ja gemacht).
Das geschieht hier in dieser Zeile
Set SH = .Shapes.AddShape(msoShapeOval, Xm + i * 10, Ym - Dm / 2, D, D)
Da kannst anstelle "Xm + i * 10" bzw. "Ym - Dm / 2" mit einem gelesenen Wert aus einer Vorgabetabelle arbeiten
unabhängig davon hab ich noch folgenden Code gefunden,
Sub PlatzoptimierteKreisverteilung()
Dim ws As Worksheet
Dim bigCircleSize As Double
Dim smallCircleRadius As Double
Dim numCircles As Integer
Dim angleIncrement As Double
Dim centerX As Double
Dim centerY As Double
Dim off As Integer
Dim i As Integer
'Größe des großen Kreises
bigCircleSize = InputBox("Durchmesser großer Kreis", , "300")
'Offset großer Kreis
off = 10
'Radius der kleinen Kreise
smallCircleRadius = InputBox("Durchmesser kleine Kreise", , "20")
'Anzahl der kleinen Kreise
numCircles = InputBox("Anzahl kleien Kreise", , "10")
'Berechne den Winkelabstand zwischen den Kreisen
angleIncrement = 360 / numCircles
'Bestimme den Mittelpunkt des großen Kreises
centerX = bigCircleSize / 2 + off
centerY = bigCircleSize / 2 + off
Set ws = ThisWorkbook.Worksheets.Add
'Zeichne den großen Kreis
With ws.Shapes.AddShape(msoShapeOval, off, off, bigCircleSize, bigCircleSize)
.Fill.Visible = msoTrue
.Fill.Solid
.Fill.ForeColor.RGB = RGB(255, 255, 255)
.Line.Visible = msoTrue
End With
'Platziere die kleinen Kreise innerhalb des großen Kreises
For i = 1 To numCircles
'Berechne den Winkel für die Position des Kreises
Dim angle As Double
angle = (i - 1) * angleIncrement
'Berechne die Koordinaten des Kreismittelpunkts
Dim x As Double
Dim y As Double
x = centerX + (bigCircleSize / 2 - smallCircleRadius) * Cos(angle * 3.14159 / 180)
y = centerY + (bigCircleSize / 2 - smallCircleRadius) * Sin(angle * 3.14159 / 180)
'Zeichne den kleinen Kreis
With ws.Shapes.AddShape(msoShapeOval, x - smallCircleRadius, y - smallCircleRadius, 2 * smallCircleRadius, 2 * smallCircleRadius)
.Fill.Visible = msoTrue
.Fill.Solid
.Fill.ForeColor.RGB = RGB(0, 0, 255)
.Line.Visible = msoFalse
End With
Next i
End Sub
Evtl. kannst du ja eine Kombination aus Beiden vornehmen
LG UweD