お皿がナントナク　デキタ - インストールレスプログラミング( ´ー`)

カタカナで文字でしゃべるのが好きなんです。　すみません。

今洗濯機がぐるぐる回っているので，終わるまで寝れないのでお風呂で考えていたことをコードにしてみました。

円は難しいとか思ってた自分は何を考えていたんだろう。円のほうが簡単じゃないか。

中心との距離を出して，それに各図形の対角線を足せば少なくともそれぞれの図形を覆える気がする。

そんな風に考えて，気の向くままバタバタと組んでみました。

Option Explicit

Sub test()
Dim TargetSlide As Slide: Set TargetSlide = ActivePresentation.Slides(1)

Dim ShapeCenter As Shape: Set ShapeCenter = TargetSlide.Shapes("中心")
Dim CenterX As Currency, CenterY As Currency
Dim arrName() As String: ReDim arrName(1 To TargetSlide.Shapes.Count)
CenterX = ShapeCenter.Left + ShapeCenter.Width / 2
CenterY = ShapeCenter.Top + ShapeCenter.Height / 2

Dim dX As Currency, dY As Currency
Dim R As Currency, tmpR As Currency
Dim s As Shape
Dim i As Long: i = 1

For Each s In TargetSlide.Shapes
    If s.Name <> ShapeCenter.Name Then
        dX = s.Left + s.Width / 2 - CenterX
        dY = s.Top + s.Height / 2 - CenterY
        tmpR = Sqr(dX ^ 2 + dY ^ 2) + Sqr((s.Width / 2) ^ 2 + (s.Height / 2) ^ 2)
        If tmpR > R Then R = tmpR
        arrName(i) = s.Name
        i = i + 1
    End If
Next

With TargetSlide.Shapes.AddShape(msoShapeOval, CenterX - R, CenterY - R, R * 2, R * 2)
    .Fill.Visible = msoFalse
    .Line.Visible = msoFalse
    arrName(i) = .Name
End With

With TargetSlide.Shapes.Range(arrName).Group
    .Name = "お皿"
End With

Do
    TargetSlide.Shapes("お皿").Rotation = TargetSlide.Shapes("お皿").Rotation + 1
    If TargetSlide.Shapes("お皿").Rotation = 360 Then TargetSlide.Shapes("お皿").Rotation = 0
    ShapeCenter.TextFrame.TextRange = " "
    DoEvents
Loop
    
End Sub