Powerpoint VBAを使おう!

Powerpoint VBAやExcelのVBAで遊んでいます。Word VBAも始めました。

お皿がナントナク デキタ

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

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

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

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

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

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

ほんとうに気の向くまま書いたコード。

こんなん動くか!?と思って実行すると,
f:id:chemiphys:20170207225619g:plain

なんか動きました。Sleepとかを入れれてないので速度は安定しないけど回ってますね

これきれいに書いたらできそうだなぁ(ΦωΦ)