インストールレスプログラミング( ´ー`)

VBA , JavaScript , HTAなど 365アプリはインストール必要ですが、仕事に無いケースはほぼないから(・_・;)

原子の構造　一旦，完成

Powerpoint VBA

どれの続きなのかもうわからない。作るときもブログ書くときもてきとー極まりありません。

んー構想の続きがベストかな。

chemiphys.hateblo.jp

今日は，時間を確保して，なんとか作りました。

f:id:chemiphys:20170216191101g:plain

・各元素のボタンを準備して，２０番目まで選べるようにしました。

・大きさはちゃんと変化するようにしました。

・閉殻になっている電子殻には色を塗っています。また，電子の回転も最外殻と逆向きにしてみました。速度も少し差をつけています。

・原子核の粒子数もいちおう数値にあわせてきちんと変化させています。重なって実際には見えないものもある場合はあるとは思いますが，雰囲気は十分伝えることができるかなぁと思います。

コード中のこだわった部分に，次の記事で触れようと思います。

コードはこちら。

標準モジュール

Option Explicit
Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwm As Long)

Type Position
    x As Currency
    y As Currency
End Type
Const 原子核x = 300, 原子核y = 280
Const PI As Currency = 3.1415
Const 半径 = 10
Const 原子大きさ補正 = 33
Const 電子殻間隔 = 25
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"
Const arr質量数 = "1,4,7,9,11,12,14,16,19,20,23,24,27,28,31,32,35,40,39,40"
Const arr元素記号 = "H,He,Li,Be,B,C,N,O,F,Ne,Na,Mg,Al,Si,P,S,Cl,Ar,K,Ca"
Dim StopFlag As Boolean
Public TargetSlide As Slide
Sub Start()
    Set TargetSlide = ActivePresentation.Slides(1)
'    TargetSlide.Shapes.Range.Delete
    
    Dim i As Long
    For i = 1 To 20
        With TargetSlide.Shapes.AddTextbox(msoTextOrientationHorizontal, 600 + Int((i - 1) / 10) * 100, ((i - 1) Mod 10) * 40 + 20, 70, 20)
            .Fill.ForeColor.RGB = vbYellow
            .Name = i
            .TextFrame.TextRange = i & Split(arr元素記号, ",")(i - 1)
            .ActionSettings(ppMouseClick).Action = ppActionRunMacro
            .ActionSettings(ppMouseClick).Run = "Make"
        End With
    Next
    
    With TargetSlide.Shapes.AddTextbox(msoTextOrientationHorizontal, 600, 420, 170, 50)
        .TextFrame.TextRange.Text = "STOP"
        .ActionSettings(ppMouseClick).Action = ppActionRunMacro
        .ActionSettings(ppMouseClick).Run = "StopMacro"
        .Fill.ForeColor.RGB = vbRed
        .Name = "0"
    End With
    
    ActivePresentation.SlideShowSettings.Run
    SlideShowWindows(1).View.PointerType = ppSlideShowPointerArrow

End Sub

Sub Make(図形 As Shape)
    Set TargetSlide = ActivePresentation.Slides(1)
    
    Dim i As Long
    For i = TargetSlide.Shapes.Count To 1 Step -1
        If IsNumeric(TargetSlide.Shapes(i).Name) = False Then TargetSlide.Shapes(i).Delete
    Next
    
    Dim 原子番号 As Long
    Dim Plate(1 To 4) As PlateObject
    
    
    原子番号 = CLng(図形.Name)
    
    For i = 1 To 4
        Set Plate(i) = New PlateObject
    Next
    
    For i = Switch(原子番号 < 3, 1, 原子番号 < 11, 2, 原子番号 < 19, 3, 原子番号 > 18, 4) To 1 Step -1
        Set Plate(i) = 電子殻(原子番号, i)
    Next
    
    Call 原子核描画(原子番号, 原子核x, 原子核y)
    
    StopFlag = False
    
    Do
        Select Case 原子番号
            Case 1
                Plate(1).RotateRight 3
            Case 2
                Plate(1).RotateLeft 1
            Case Is < 10
                Plate(1).RotateLeft 1
                Plate(2).RotateRight 3
            Case 10
                Plate(1).RotateLeft 1
                Plate(2).RotateLeft 1
            Case Is < 18
                Plate(1).RotateLeft 1
                Plate(2).RotateLeft 1
                Plate(3).RotateRight 3
            Case 18
                Plate(1).RotateLeft 1
                Plate(2).RotateLeft 1
                Plate(3).RotateLeft 1
            Case Else
                Plate(1).RotateLeft 1
                Plate(2).RotateLeft 1
                Plate(3).RotateLeft 1
                Plate(4).RotateRight 3
        End Select

        DoEvents
        Sleep 50
        TargetSlide.Shapes("0").TextFrame.TextRange.Text = "STOP"
    
        If StopFlag = True Then Exit Do
        
    Loop
End Sub

Sub StopMacro()
    StopFlag = True
End Sub
Sub 原子核描画(原子番号 As Long, StartX As Long, StartY As Long)
    Dim 粒子() As Shape, 粒子数 As Long
    Dim i As Long, j As Long
    Dim dX As Long, dY As Long
    Dim R As Long
    
    
    粒子数 = CLng(Split(arr質量数, ",")(原子番号 - 1))
    
    ReDim 粒子(粒子数)
    i = 粒子数
    
    Do
        Select Case i
            Case Is <= 4
                If i <= 4 Then R = 8
                dX = R * Cos(2 * PI / 4 * i)
                dY = R * Sin(2 * PI / 4 * i)
            Case Is <= 8
                R = 15
                dX = R * Cos(2 * PI / 4 * i + PI / 6)
                dY = R * Sin(2 * PI / 4 * i + PI / 6)
            Case Is <= 12
                R = 15
                dX = R * Cos(2 * PI / 4 * i + PI / 6 * 2)
                dY = R * Sin(2 * PI / 4 * i + PI / 6 * 2)
            Case Is <= 18
                R = 15
                dX = R * Cos(2 * PI / 4 * i)
                dY = R * Sin(2 * PI / 4 * i)
            Case Is <= 34
                If 粒子数 <= 22 Then R = 21 Else R = 24
                dX = R * Cos(2 * PI / 16 * 9 * i)
                dY = R * Sin(2 * PI / 16 * 9 * i)
            Case Else
                R = 29
                dX = R * Cos(2 * PI / 4 * i + PI / 4)
                dY = R * Sin(2 * PI / 4 * i + PI / 4)
        End Select
    
        Set 粒子(i) = TargetSlide.Shapes.AddShape(msoShapeOval, StartX + dX, StartY + dY, 15, 15)
        粒子(i).Fill.ForeColor.RGB = vbCyan
        粒子(i).ThreeD.BevelBottomDepth = 7.5
        粒子(i).ThreeD.BevelBottomInset = 7.5
        粒子(i).ThreeD.BevelTopDepth = 7.5
        粒子(i).ThreeD.BevelTopInset = 7.5
        粒子(i).Line.Visible = msoFalse
        i = i - 1
    Loop Until i = 0
        
    Dim arr As String
    For i = 1 To 粒子数
        arr = arr & vbTab & 粒子(i).Name
    Next

    If 粒子数 = 1 Then
        粒子(1).Name = "原子核"
    Else
        With TargetSlide.Shapes.Range(Split(arr, vbTab)).Group
            .Name = "原子核"
        End With
    End If
    Dim shp原子核 As Shape: Set shp原子核 = TargetSlide.Shapes("原子核")
    shp原子核.Left = 原子核x - shp原子核.Width / 2
    shp原子核.Top = 原子核y - shp原子核.Height / 2
    
    Dim ret As Long
    j = 1
    Do
        ret = Int(Rnd * 粒子数)
        If ret = 0 Then ret = 1
        If 粒子(ret).Fill.ForeColor.RGB = vbCyan Then
            粒子(ret).Fill.ForeColor.RGB = vbRed
            j = j + 1
        End If
    Loop Until j > 原子番号

End Sub

Function 電子殻(AtomNo As Long, pNo As Long) As PlateObject
    Dim R As Currency
    R = Split(arr原子大きさ, ",")(AtomNo - 1) * 原子大きさ補正
    Dim EleNo As Long
    Select Case pNo
        Case 1
            If AtomNo = 1 Then EleNo = 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() As Shape: ReDim shp(EleNo)
    Dim decreaseR As Long: decreaseR = Switch(AtomNo < 3, 0, AtomNo < 11, 2 - pNo, AtomNo < 19, 3 - pNo, AtomNo > 18, 4 - pNo) * 電子殻間隔
    
    Set shp(0) = MakeOval(原子核x, 原子核y, R - decreaseR, vbBlack, RGB(153, 204, 255), False)

    Dim rad As Currency: rad = 2 * PI / EleNo
    
    Dim i As Long
    For i = 1 To EleNo
        Set shp(i) = MakeOval(原子核x + (R - decreaseR) * Cos(rad * i), 原子核y + (R - decreaseR) * Sin(rad * i))
    Next
        
    If (pNo = 1 And EleNo = 2) Or (pNo <> 1 And EleNo = 8) Then
        shp(0).Fill.ForeColor.RGB = RGB(153, 204 - pNo * 20, 255)
        shp(0).Fill.Visible = msoTrue
        For i = 1 To EleNo
            shp(i).Fill.ForeColor.RGB = RGB(146, 208, 80)
        Next
    End If
    Dim arr As Variant
    arr = shp
    Set 電子殻 = New PlateObject
    電子殻.Assemble arr, 原子核x, 原子核y
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 ShapeIndex() As Long

Public Sub Assemble(Arg As Variant, CenterX As Currency, CenterY As Currency)
    Dim s As Shape
    Dim ShapePos() As Position: ReDim ShapePos(UBound(Arg))
    ReDim ShapeIndex(UBound(Arg) + 1)
    Dim i As Long
    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
        ShapeIndex(i) = SIndex(s)
    Next

    CenterPosition.x = CenterX
    CenterPosition.y = CenterY
    Dim tmpRadius As Currency
    Dim PlateRadius As Currency
    
    PlateRadius = 0
    For i = 0 To UBound(ShapeIndex) - 1
        Set s = TargetSlide.Shapes(ShapeIndex(i))
        tmpRadius = Sqr((Pos(s).x - CenterPosition.x) ^ 2 + (Pos(s).y - CenterPosition.y) ^ 2) + Sqr((s.Width / 2) ^ 2 + (s.Height / 2) ^ 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
    ShapeIndex(UBound(ShapeIndex)) = SIndex(tmpPlate)
    
    Set PlateShape = TargetSlide.Shapes.Range(ShapeIndex).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
End Sub
Public Sub RotateLeft(Degree As Long)
    PlateShape.Rotation = PlateShape.Rotation - Degree
    If PlateShape.Rotation = -360 Then PlateShape.Rotation = 0
End Sub
Public Sub Delete()
    PlateShape.Delete
End Sub

ごはん食べた後，コードの部分的なコメントを書こうと思ってます。