AW: Kreis - Rechteck dynamisch
24.06.2020 09:22:30
MCO
Hallo Tobias!
Deine Figuren haben alle Breite und Höhe als Eigenschaft. Damit kannst du den Mittelpunkt bestimmen (jeweils geteilt durch 2) indem du die Position der Figur + Abmessungen nimmst.
Alte Mitte mit neuen Abmessungen = neue Position
Als code sieht das dann so aus:
Sub Größe_andern_Kreis()
With ActiveSheet.Shapes.Range(Array("Oval 2"))
Mitte_vert = .Top + .Height / 2
Mitte_hori = .Left + .Width / 2
.Height = Application.CentimetersToPoints(Range("B5"))
.Width = .Height
.Top = Mitte_vert - .Height / 2
.Left = Mitte_hori - .Width / 2
End With
End Sub
Sub Größe_andern_Rechteck()
With ActiveSheet.Shapes.Range(Array("Rectangle 5"))
Mitte_vert = .Top + .Height / 2
Mitte_hori = .Left + .Width / 2
.Height = Application.CentimetersToPoints(Range("K5"))
.Width = Application.CentimetersToPoints(Range("K6"))
.Top = Mitte_vert - .Height / 2
.Left = Mitte_hori - .Width / 2
End With
End Sub
In Tabelle1 gehört noch dieser Code
Private Sub Worksheet_Change(ByVal Target As Range)
If Target = "" Then Exit Sub
If Not IsNumeric(Target) Then Exit Sub
Set Eingabe_kreis = Application.Intersect(Target, Range("B5"))
Set Eingabe_Ø = Application.Intersect(Target, Range("K5:K6"))
If Not Eingabe_kreis Is Nothing Then Größe_andern_Kreis
If Not Eingabe_Ø Is Nothing Then Größe_andern_Rechteck
End Sub
https://www.herber.de/bbs/user/138514.xlsm
Gruß, MCO