Graphische platzierung von Kreisen 2 - VBA
29.11.2016 07:26:07
Kreisen
Da meine Anfrage leider zu schnell geschlossen wurde, hier nun Teil 2
UweD hat mir schon mal eine tolle Lösung kreiert (sieher Verlauf unten).
Lässt sich hier nun eine Funktion einbauen, mit der man die eingesetzten Kreise per Doppelklick innerhalb des Umkreises gleichmässig verteilen kann?
Besten Dank schon mal für eure Kommentare
Klaus
**********************************
Da ich selber in vba nur ganz einfach Programme verfassen kann habe ich folgende Frage an euch Programmierspezialisten.
Lässt sich die folgende Problemstellung z.B. in Excel mittels VBA bewerkstelligen?
Ich möchte auf Grund einer Auswahl (Durchmesser) in einer Zelle an einem definierten Ort auf einem Excelsheet eine Kreisrunde Basisfläche erstellen.
Innerhalb dieser Kreisfläche möchte ich verschieden grosse Kreise platzieren, welche sich verschieben lassen. Es wäre schön, wenn man über zwei Auswahlzellen die Anzahl und den durchmesser dieser Kreise festlegen und per Einfügenbutton zunächst mal wild auf der Kreisfläche platzieren könnte. Dieser vorgang sollte wiederholbar sein bis im Worstcase kein freier Platz mehr auf der Kreisfläche zur Verfügung steht.
Es sollte wenn möglich eine Kollisionsprüfung zwischen den eingesetzten Kreisen auf einen zu definierenden Abstand (Festwert im VBA Code) stattfinden. Beim Umkreis dürfen die Kreise satt anliegen, aber nicht überlappen.
Als Krönung wäre es genial wenn man am Ende (alle Kreise platziert wie man möchte) per Button eine Liste generieren könnte, die die Koordinaten der Mittelpunkte aller platzierter Kreise in Abhängigkeit zum Mittelpunkt der Kreisfläche auflistet.
Besten Dank schon mal für eure Kommentare
Klaus
Für den untersten Teil schon mal eine mögliche Lösung..
Sub Kreise()
Dim SH, i As Integer, MMx, MMy, MPx, MPy
i = 2
With Sheets("Tabelle1")
.Cells(1, 1).Select
.Cells.Clear 'reset
.Cells(1, 1) = "Name"
.Cells(1, 2) = "Mittelpunkt X"
.Cells(1, 3) = "Mittelpunkt Y"
.Cells(1, 4) = "Durchmesser X"
'.Cells(1, 5) = "Durchmesser Y" 'kann weg, wenn Kreis
For Each SH In .Shapes
If SH.Type = 1 Or SH.Type = 9 Then
If SH.Name = "Master" Then
MMx = SH.Left + SH.Width / 2
MMy = SH.Top + SH.Height / 2
.Cells(2, 1) = SH.Name
.Cells(2, 2) = MMx
.Cells(2, 3) = MMy
.Cells(2, 4) = SH.Width
'.Cells(2, 5) = SH.Height 'kann weg, wenn Kreis
Else
i = i + 1
MPx = SH.Left + SH.Width / 2 - MMx
MPy = SH.Top + SH.Height / 2 - MMy
.Cells(i, 1) = SH.Name
.Cells(i, 2) = MPx
.Cells(i, 3) = MPy
.Cells(i, 4) = SH.Width
'.Cells(i, 5) = SH.Height'kann weg, wenn Kreis
SH.TextFrame.Characters.Text = SH.Name
End If
End If
Next SH
.Columns("B:E").NumberFormat = "#,##0.00"
End With
End Sub
https://www.herber.de/bbs/user/109270.xlsm
LG UweD
Hallo
..hab ich es. Das ist mir zu kompliziert
- Rechtsclick auf den Tabellenblattreiter
- Code anzeigen
- Diesen Code dort reinkopieren
Option Explicit
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Not Intersect(Range("J1:J4"), Target) Is Nothing Then
Cancel = True
Select Case Target.Address
Case "$J$1"
Call Masterkreis
Case "$J$2", "$J$3"
Call KleineKreise
Case "$J$4"
Call KreiseAuflistung
End Select
End If
End Sub
Sub Masterkreis()
Dim Xm&, Ym&, Dm&, SH As Shape
'Mittelpunkt
Xm = 500
Ym = 250
With ActiveSheet
'reset
.Columns("A:D").ClearContents
.DrawingObjects.Delete 'alle löschen
Dm = InputBox("Durchmesser", , 300)
Set SH = .Shapes.AddShape(msoShapeOval, Xm - Dm / 2, Ym - Dm / 2, Dm, Dm)
SH.Name = "Master"
With SH.Fill 'gelb färben
.ForeColor.RGB = RGB(255, 255, 0)
.Solid
End With
SH.ZOrder msoSendToBack ' in Hintergrund setzen
End With
End Sub
Sub KleineKreise()
Dim Xm&, Ym&, Dm&, D&, SH As Shape, i%, z%
With ActiveSheet
z = .DrawingObjects.Count 'Anzahl bereits vorhandener Objekte
'Daten von Master
Xm = .Shapes("Master").Left + .Shapes("Master").Width
Ym = .Shapes("Master").Top + .Shapes("Master").Width
Dm = .Shapes("Master").Width
'Neue anlegen
D = .Range("K3")
For i = z To z + .Range("K2") - 1
Set SH = .Shapes.AddShape(msoShapeOval, Xm + i * 10, Ym - Dm, D, D)
SH.Name = i
SH.TextFrame.Characters.Text = SH.Name
Next i
End With
End Sub
Sub KreiseAuflistung()
Dim SH As Shape, i%, MMx&, MMy&, MPx&, MPy&
i = 2
With ActiveSheet
.Columns("A:D").ClearContents
.Cells(1, 1) = "Name"
.Cells(1, 2) = "Mittelpunkt X"
.Cells(1, 3) = "Mittelpunkt Y"
.Cells(1, 4) = "Durchmesser"
For Each SH In .Shapes
If SH.Type = 1 Or SH.Type = 9 Then
If SH.Name = "Master" Then
MMx = SH.Left + SH.Width / 2
MMy = SH.Top + SH.Height / 2
.Cells(2, 1) = SH.Name
.Cells(2, 2) = MMx
.Cells(2, 3) = MMy
.Cells(2, 4) = SH.Width
Else
i = i + 1
MPx = SH.Left + SH.Width / 2 - MMx
MPy = SH.Top + SH.Height / 2 - MMy
.Cells(i, 1) = SH.Name
.Cells(i, 2) = MPx
.Cells(i, 3) = MPy
.Cells(i, 4) = SH.Width
End If
End If
Next SH
.Columns("A:D").EntireColumn.AutoFit
.Columns("B:E").NumberFormat = "#,##0.00"
End With
End Sub
https://www.herber.de/bbs/user/109276.xlsm
Gruß UweD
Über Rückmeldungen würde ich mich freuen
Wenn eine Aussenkreisverletzung vorliegt dann wird schon mal ein Fehler angezeigt..
Hier der komplette Code nochmal (mit Fehlerbereinigung)
Option Explicit
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Not Intersect(Range("J1:J5"), Target) Is Nothing Then
Cancel = True
Select Case Target.Address
Case "$J$1"
Call Masterkreis
Case "$J$2", "$J$3"
Call KleineKreise
Case "$J$4"
Call KreiseAuflistung
Case "$J$5"
Call Kollision
End Select
End If
End Sub
Sub Masterkreis()
Dim Xm&, Ym&, Dm&, SH As Shape
'Mittelpunkt
Xm = 500
Ym = 250
With ActiveSheet
'reset
.Columns("A:D").ClearContents
.DrawingObjects.Delete 'alle löschen
Dm = InputBox("Durchmesser", , 300)
Set SH = .Shapes.AddShape(msoShapeOval, Xm - Dm / 2, Ym - Dm / 2, Dm, Dm)
SH.Name = "Master"
With SH.Fill 'gelb färben
.ForeColor.RGB = RGB(255, 255, 0)
.Solid
End With
SH.ZOrder msoSendToBack ' in Hintergrund setzen
End With
End Sub
Sub KleineKreise()
Dim Xm&, Ym&, Dm&, D&, SH As Shape, i%, z%
With ActiveSheet
z = .DrawingObjects.Count 'Anzahl bereits vorhandener Objekte
'Daten von Master
Dm = .Shapes("Master").Width
Xm = .Shapes("Master").Left + Dm / 2
Ym = .Shapes("Master").Top + Dm / 2
'Neue anlegen
D = .Range("K3")
For i = z To z + .Range("K2") - 1
Set SH = .Shapes.AddShape(msoShapeOval, Xm + i * 10, Ym - Dm / 2, D, D)
SH.Name = i
SH.TextFrame.Characters.Text = SH.Name
Next i
End With
End Sub
Sub KreiseAuflistung()
Dim SH As Shape, i%, MMx&, MMy&, MPx&, MPy&, D&
i = 2
With ActiveSheet
.Columns("A:D").ClearContents
.Cells(1, 1) = "Name"
.Cells(1, 2) = "Mittelpunkt X"
.Cells(1, 3) = "Mittelpunkt Y"
.Cells(1, 4) = "Durchmesser"
For Each SH In .Shapes
If SH.Type = 1 Or SH.Type = 9 Then
If SH.Name = "Master" Then
D = SH.Width
MMx = SH.Left + D / 2
MMy = SH.Top + D / 2
.Cells(2, 1) = SH.Name
.Cells(2, 2) = MMx
.Cells(2, 3) = MMy
.Cells(2, 4) = D
Else
i = i + 1
D = SH.Width
MPx = SH.Left + D / 2 - MMx
MPy = SH.Top + D / 2 - MMy
.Cells(i, 1) = SH.Name
.Cells(i, 2) = MPx
.Cells(i, 3) = MPy
.Cells(i, 4) = D
End If
End If
Next SH
.Columns("B:E").NumberFormat = "#,##0.00"
End With
End Sub
Sub Kollision()
Dim SH As Shape, i%, MMx&, MMy&, Rm&, MPx&, MPy&, Rd&
Dim Ab&, M&, TMP As Boolean
With ActiveSheet
'Daten von Master
Rm = .Shapes("Master").Width / 2
MMx = .Shapes("Master").Left + Rm
MMy = .Shapes("Master").Top + Rm
M = .Range("K5") 'Mindestabstand
For Each SH In .Shapes
If SH.Type = 1 Or SH.Type = 9 Then
If SH.Name "Master" Then
Rd = SH.Width / 2
MPx = SH.Left + Rd
MPy = SH.Top + Rd
Ab = Sqr((MPx - MMx) ^ 2 + (MPy - MMy) ^ 2)
If Ab + Rd > Rm - M Then
MsgBox "Fehler bei " & SH.Name
TMP = True
End If
End If
End If
Next SH
End With
If TMP = False Then MsgBox "Keine Aussenkreisverletzung"
End Sub
LG UweD
Hi Uwe,
da haste ja gebastelt!
Ist zwar nicht meine Frage, sieht aber klasse aus...
Die Frage ist, wie man so was steuern will: wie kommt man an den zuletzt verschobenen Kreis ran?
Mann, mein Tatort fängt an, also GANZ schnell:
- das Selektieren/Verschieben eines Kreises löst anscheinend keinen Event aus
- bin mal wieder über den Pearson gestolpert: http://www.cpearson.com/excel/Events.aspx
Vielleicht könnte man aus der "Kreistabelle" ein Chart (als extra "Blatt") erstellen, dann stehen dort ein paar Maus-Events zur Verfügung.
Die Sache zu steuern, ist gar nicht so einfach: entweder man setzt einfach einen Kreis und überprüft, ob eine Kollision vorliegt (und verschiebt ihn ggf) oder man ermittelt erst Mal "freie Bereiche" - das ist eine üble Rechnerei, oder?
Müßte sich aber trotzdem irgendwie lösen lassen - nur nicht mehr heute Abend.
Schöne Grüße,
Michael
Hallo Michael
Ich hab es so verstanden, dass die Kreise händisch verteilt werden.
LG UweD
Hi Uwe,
da hast Du wohl Recht.
Ich hatte gleich so eine Art physikalische Vorstellung, bei der sich die benachbarten Kreise, wenn man einen schubst, weiterbewegen...
Für so was gibt es sicher schon Modelle, nur ob die irgendjemand in Excel umgesetzt hat, weiß ich nicht.
Naja, nur so ein Gedanke.
Vielen Dank für die Lösung (und an Klaus für die Frage),
LG Michael
So, die Überlappungsprüfung ist auch eingebaut.
das letzte Makro austauschen
Sub Kollision()
Dim SH As Shape, i%, z%, MMx&, MMy&, Rm&, MPx&, MPy&, Rd&
Dim Ab&, M&, TMP As Boolean, MIx&, MIy&, RI&
With ActiveSheet
'Daten von Master
Rm = .Shapes("Master").Width / 2
MMx = .Shapes("Master").Left + Rm
MMy = .Shapes("Master").Top + Rm
M = .Range("K5") 'Mindestabstand
For i = 1 To .Shapes.Count
Set SH = .Shapes(i)
If SH.Type = 1 Or SH.Type = 9 Then
If SH.Name "Master" Then
Rd = SH.Width / 2
MPx = SH.Left + Rd
MPy = SH.Top + Rd
Ab = Sqr((MPx - MMx) ^ 2 + (MPy - MMy) ^ 2)
If Ab + Rd > Rm Then
MsgBox "Aussenkreisverletzung bei " & SH.Name
TMP = True
End If
z = .Shapes.Count
Do Until z = CInt(SH.Name) + 1
RI = .Shapes(z).Width / 2
MIx = .Shapes(z).Left + RI
MIy = .Shapes(z).Top + RI
Ab = Sqr((MIx - MPx) ^ 2 + (MIy - MPy) ^ 2)
If Ab MsgBox "Abstandfehler zwischen " & SH.Name & " / " & .Shapes(z).Name
TMP = True
End If
z = z - 1
Loop
End If
End If
Next i
If TMP = False Then MsgBox "Keine Abstandfehler"
End With
End Sub
Zusammenfassend nochmal den Ablauf:
- Neuen Masterkreis anlegen
- Kleine Kreise erzeugen und händisch in Masterkreis schieben
- .. wiederholen
- Kollisionsprüfung ausführen
- Ggf händisch verschieben
- Ist alles fehlerlos, Auflistung ausführen
LG UweD
Hallo Uwe
Danke für deine superschnelle und beeindruckende Lösung.
Sieht toll aus.
Ich ziehe meinen Hut vor dir
LG Klaus
Anzeige
