Graphische platzierung von Kreisen - VBA

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

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

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

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

Wenn eine Aussenkreisverletzung vorliegt dann wird schon mal ein Fehler angezeigt..
Userbild

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

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 < Rd + RI + M Then 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

Beliebteste Forumthreads (12 Monate)

Graphische platzierung von Kreisen - VBA

9
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

115 Forumthreads zu ähnlichen Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Graphische platzierung von Kreisen - VBA

9 Beiträge zum Forumthread Beiträge zu diesem Forumthread

115 Forumthreads zu ähnlichen Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

9
Beiträge zum Forumthread

Beiträge zu diesem Forumthread