電子殻をPlateObjectで作ってみました。

chemiphys.hateblo.jp

chemiphys.hateblo.jp

久々に，PowerpointのVBAをやりたくて，全く前のを覚えてないのに，そのまま強行してみました。

電子殻が今日の興味のメインで，これを以前作ったお皿クラスモジュールでやる。

たたき台にできるレベルの動きかなぁと思います。

こんな感じです。

面倒で Sleepとかまだ入れれていないので，動きがぎこちないです。

あと，お皿が異様にでかくなるのが難点で，そこも見ないといけませんが，

電子殻ごとにPlateObjectにするというのは達成していますし，原子半径を反映して大きさが変わる仕様には，もうなっています。

時間がまったくないので，原子核は今日は考えるのをやめました。

少し前向きに，原子の構造はがんばります。時間を何とか作る。

コードはまだまだのものですが，載せておきます。

標準モジュール

Option Explicit
Type Position
    x As Currency
    y As Currency
End Type
Const x = 100, y = 200
Const 半径 = 10
Const arr原子大きさ = "1,4.67,5.07,3.70,2.70,2.57,2.47,2.47,2.40,5.13,6.20,5.33,4.77,3.90,3.67,3.47,3.30,6.27,7.70,6.57"
Dim StopFlag As Boolean
Dim TargetSlide As Slide
Sub test()
    Set TargetSlide = ActivePresentation.Slides(1)
    TargetSlide.Shapes.Range.Delete
    
    Dim ret As Variant
    ret = InputBox("原子番号を入力してください。")
    With TargetSlide.Shapes.AddTextbox(msoTextOrientationHorizontal, 500, 40, 100, 50)
        .TextFrame.TextRange.Text = "STOP"
        .ActionSettings(ppMouseClick).Action = ppActionRunMacro
        .ActionSettings(ppMouseClick).Run = "StopMacro"
        .Fill.ForeColor.RGB = vbRed
        .Name = "StopButton"
    End With
    
    Call Make(CLng(ret))

End Sub


Sub Make(原子番号 As Long)
Dim Plate(1 To 4) As PlateObject
Dim i As Long
For i = 1 To 4
    Set Plate(i) = New PlateObject
Next

For i = 1 To Switch(原子番号 < 3, 1, 原子番号 < 11, 2, 原子番号 < 19, 3, 原子番号 > 18, 4)
    Set Plate(i) = 電子殻(原子番号, i)
Next

StopFlag = False

ActivePresentation.SlideShowSettings.Run
Do
    For i = 1 To Switch(原子番号 < 3, 1, 原子番号 < 11, 2, 原子番号 < 19, 3, 原子番号 > 18, 4)
        Plate(i).RotateRight Degree:=1
    Next
    DoEvents
    TargetSlide.Shapes("StopButton").TextFrame.TextRange.Text = "STOP"

    If StopFlag = True Then Exit Do
    
Loop
SlideShowWindows(1).View.Exit
End Sub

Sub StopMacro()
    StopFlag = True
End Sub
Function 電子殻(AtomNo As Long, pNo As Long) As PlateObject
    Dim r As Currency
    r = Split(arr原子大きさ, ",")(AtomNo - 1) * 50
    Dim EleNo As Long
    Select Case pNo
        Case 1
            If AtomNo > 1 Then EleNo = 2
        Case 2
            If AtomNo > 10 Then EleNo = 8 Else EleNo = AtomNo - 2
        Case 3
            If AtomNo > 18 Then EleNo = 8 Else EleNo = AtomNo - 10
        Case 4
            EleNo = AtomNo - 18
    End Select
    
    Dim shp(): ReDim shp(EleNo)
    Dim decreaseR As Long: decreaseR = Switch(AtomNo < 3, 0, AtomNo < 11, 2 - pNo, AtomNo < 19, 3 - pNo, AtomNo > 18, 4 - pNo) * 25
    
    Set shp(0) = MakeOval(250, 250, r - decreaseR, vbBlack, vbRed, False)

    Dim rad As Currency: rad = 2 * 3.1415 / EleNo
    
    Dim i As Long
    For i = 1 To EleNo
        Set shp(i) = MakeOval(250 + (r - decreaseR) * Cos(rad * i), 250 + (r - decreaseR) * Sin(rad * i))
    Next
    Dim arr As Variant
    arr = shp
    Set 電子殻 = New PlateObject
    電子殻.Assemble arr
    電子殻.SetCenter 250, 250
End Function


Function MakeOval(x As Long, y As Long, Optional r As Long = 半径, Optional LineColor As Long = vbBlack, Optional FillColor As Long = vbYellow, Optional FillVisible As Boolean = True) As Shape
    Set MakeOval = TargetSlide.Shapes.AddShape(msoShapeOval, x - r, y - r, r * 2, r * 2)
    MakeOval.Line.ForeColor.RGB = LineColor
    MakeOval.Fill.ForeColor.RGB = FillColor
    If FillVisible = True Then MakeOval.Fill.Visible = msoTrue Else MakeOval.Fill.Visible = False
End Function

PlateObject.cls

Option Explicit
Private CenterPosition As Position
Private PlateRotation As Long
Private PlateShape As Shape
Private ShapeID() As Long
Private TargetSlide As Slide

'Public Sub Assemble(ParamArray ArgShapes())
Public Sub Assemble(Arg As Variant)
    Dim s As Shape
    Dim ShapePos() As Position: ReDim ShapePos(UBound(Arg))
    ReDim ShapeID(UBound(Arg) + 1)
    Dim i As Long: i = 0
    For i = 0 To UBound(Arg)
        Set s = Arg(i)
        If i = 0 Then
            Set TargetSlide = ActivePresentation.Slides(s.Parent.SlideIndex)
        End If
        ShapePos(i).x = Pos(s).x
        ShapePos(i).y = Pos(s).y
        ShapeID(i) = SIndex(s)

    Next
End Sub
Public Sub SetCenter(CenterX As Currency, CenterY As Currency)
    CenterPosition.x = CenterX
    CenterPosition.y = CenterY
    Dim tmpRadius As Currency
    Dim PlateRadius As Currency
    
    Dim i As Long: i = 0
    Dim s As Shape
    
    PlateRadius = 0
    For i = 0 To UBound(ShapeID) - 1
        Set s = TargetSlide.Shapes(ShapeID(i))
        tmpRadius = Sqr((Pos(s).x - CenterPosition.x) ^ 2 + (Pos(s).y - CenterPosition.y) ^ 2) + Sqr(s.Width ^ 2 + s.Height ^ 2)
        If tmpRadius > PlateRadius Then PlateRadius = tmpRadius
    Next
    
    Dim tmpPlate As Shape
    Set tmpPlate = TargetSlide.Shapes.AddShape(msoShapeOval, CenterPosition.x - PlateRadius, CenterPosition.y - PlateRadius, PlateRadius * 2, PlateRadius * 2)
        tmpPlate.Fill.Visible = msoFalse
        tmpPlate.Line.Visible = msoFalse
    ShapeID(UBound(ShapeID)) = SIndex(tmpPlate)
    
    Set PlateShape = TargetSlide.Shapes.Range(ShapeID).Group
End Sub
Private Function Pos(TargetShape As Shape) As Position
    Pos.x = TargetShape.Left + TargetShape.Width / 2
    Pos.y = TargetShape.Top + TargetShape.Height / 2
End Function
Function SIndex(ByVal TargetShape As PowerPoint.Shape) As Long
    Dim TargetSlide As Slide: Set TargetSlide = ActivePresentation.Slides(TargetShape.Parent.SlideIndex)
    
    If TargetShape.Child = msoTrue Then '完全に真似させてもらった。グループ内図形の場合は親を返す
        Let SIndex = SIndex(TargetShape.ParentGroup)
        Exit Function
    End If
    
    Dim db As Object: Set db = CreateObject("Scripting.Dictionary")
    Dim s As Shape
    Dim i As Long: i = 1
    
    For Each s In TargetSlide.Shapes
        db(s.Id) = i
        i = i + 1
    Next
    
    Let SIndex = db.Item(TargetShape.Id)
    
End Function
Public Sub RotateRight(Degree As Long)
    PlateShape.Rotation = PlateShape.Rotation + Degree
    If PlateShape.Rotation = 360 Then PlateShape.Rotation = 0
    TargetSlide.Shapes(1).TextFrame.TextRange = " "
    DoEvents
End Sub
Public Sub RotateLeft(Degree As Long)
    PlateShape.Rotation = PlateShape.Rotation - Degree
    If PlateShape.Rotation = -360 Then PlateShape.Rotation = 0
    TargetSlide.Shapes(1).TextFrame.TextRange = " "
    DoEvents
End Sub

内部的にはあんまり変わらないかもですが，ParamArrayより，配列Variantを放り込む方がやりすやかった。

その辺はほんとまだまだ不得手なところなので，いろいろやりながら，コーディングの力を上げないとですね。

大きさは理論値優先で画面からはみ出ても今はきにしていません。

もうちょっと小さくしたり，Constで宣言部に集めたり，と修正箇所山のようにアリマスネ。。

今からイマカラ・・。

ちょうどいい大きさのやつが運よく表示されたらおーと思っていただけると‥(;´▽｀A``