原子の構造と電子配置①

ネタ探しとか言っている場合ではない。

化学が専門の教員なのに，電子配置やら原子の構造やらを説明するものを作っていなかった。

これはちゃんとツクラナケレバ。

と思い立ち，とりあえず構想を練り始め。

原子核のことを表したい。
電子配置も同時に示したい。

もともと原子核というのは，原子の大きさに対しきわめて小さいので，自分の説明に都合がいいようにデフォルメしたい。

原子核中の陽子の数が増えたら，中性子もそれにつられて増える感じなんかも入れたいですし，電子は動かして，回ってることをアピールしたい。

とりあえず惑星ぽいのを流用していくつかの電子を回してみました。ちゃんと考えていないことがよくわかる。

同じ対象のまわりをぐるぐる回る場合，いろいろと支障があるようです。

いろいろ見直さないとな。

たぶん作れそうではある。

図形手動で消してるのが画像記録されてしまったけど　消すように作ってた　ハズカシイ(;´▽｀A``

とりあえずの電子を回してみるだけのコード。止める機構とかありませんから，手動で止めてください
標準モジュール

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

Sub 原子模型作成()
    Dim TargetSlide As Slide: Set TargetSlide = ActivePresentation.Slides(1)
    TargetSlide.Shapes.Range.Delete
    Dim 電子数 As Long: 電子数 = InputBox("電子数?")
    
    Dim AtomCore As ShpCls: Set AtomCore = New ShpCls
    AtomCore.SetShp TargetSlide.Shapes.AddShape(msoShapeOval, 150, 150, 30, 30)
    
    Call 電子殻描画(電子数, AtomCore)
    
    Dim Electron(20) As ShpCls
    Dim p(20) As Parts
    
    Dim i As Long, 半径 As Long, 色 As Long, 補正 As Currency, 角度差分 As Long
    For i = 1 To 電子数
        Set Electron(i) = New ShpCls
        Set p(i) = New Parts
            
            Select Case i
                Case Is <= 2
                    半径 = 30: 色 = vbRed: 補正 = 0.5
                Case Is <= 10
                    半径 = 50: 色 = vbBlue: 補正 = 1
                Case Is > 10
                    半径 = 70: 色 = vbYellow: 補正 = 1.5
            End Select
                    
            Electron(i).SetShp TargetSlide.Shapes.AddShape(msoShapeOval, AtomCore.X + 半径, AtomCore.Y, 10, 10)
            Electron(i).Shp.Fill.ForeColor.RGB = 色
            p(i).SetShp Electron(i).Shp, AtomCore.Shp, 補正
            
    Next
    
    
    ActivePresentation.SlideShowSettings.Run
    Dim j As Long, angle As Currency, 角度補正 As Currency
    Do
        angle = j * 3.14 / 180 * 10
        
        For i = 1 To 電子数
            角度補正 = 3.14 / 180 * Switch(i <= 2, 360 * i, i <= 10, 135 * (i - 2), i >= 10, 135 * (i - 10))
            p(i).Move angle + 角度補正
        Next
        AtomCore.Shp.TextFrame.TextRange = " "
        DoEvents
        Sleep 100
        j = j + 1
    Loop
End Sub

Sub 電子殻描画(電子数 As Long, 原子核 As ShpCls)
    Dim TargetSlide As Slide: Set TargetSlide = ActivePresentation.Slides(1)
    
    With TargetSlide.Shapes.AddShape(msoShapeOval, 原子核.X - 35, 原子核.Y - 35, 70, 70)
        .Fill.Visible = msoFalse
        .Line.ForeColor.RGB = vbBlack
    End With
    
    If 電子数 > 2 Then
        With TargetSlide.Shapes.AddShape(msoShapeOval, 原子核.X - 55, 原子核.Y - 55, 110, 110)
            .Fill.Visible = msoFalse
            .Line.ForeColor.RGB = vbBlack
        End With
    End If
    
    If 電子数 > 10 Then
        With TargetSlide.Shapes.AddShape(msoShapeOval, 原子核.X - 75, 原子核.Y - 75, 150, 150)
            .Fill.Visible = msoFalse
            .Line.ForeColor.RGB = vbBlack
        End With
    End If
    
End Sub

Parts.cls

Option Explicit

Private pR As Currency
Private s1 As ShpCls
Private sc As ShpCls
Private pAngleRate As Currency

Public Sub SetShp(pShp1 As Shape, pShpCenter As Shape, 角度係数 As Currency)
    Set s1 = New ShpCls: s1.SetShp pShp1
    Set sc = New ShpCls: sc.SetShp pShpCenter
    pR = Sqr((s1.X - sc.X) ^ 2 + (s1.Y - sc.Y) ^ 2)
    pAngleRate = 角度係数
End Sub

Public Sub Move(pAngle As Currency)
    s1.X = sc.X + pR * Cos(pAngle * pAngleRate)
    s1.Y = sc.Y + pR * Sin(pAngle * pAngleRate)
End Sub

ShpCls.cls

Option Explicit
Const PI = 3.1415
Private pShp As Shape
Private pV As Currency
Private pVAngle As Currency
Private pA As Currency
Private pAAngle As Currency

Public Sub SetShp(図形 As Shape)
    Set pShp = 図形
End Sub

Property Get Shp() As Shape
    Set Shp = pShp
End Property
Property Get X() As Currency
    X = pShp.Left + pShp.Width / 2
End Property
Property Let X(X座標 As Currency)
    pShp.Left = X座標 - pShp.Width / 2
End Property

Property Get Y() As Currency
    Y = pShp.Top + pShp.Height / 2
End Property
Property Let Y(Y座標 As Currency)
    pShp.Top = Y座標 - pShp.Height / 2
End Property

Property Get Left() As Currency
    Left = pShp.Left
End Property
Property Let Left(pLeft As Currency)
    pShp.Left = pLeft
End Property

Property Get Right() As Currency
    Right = pShp.Left + pShp.Width
End Property
Property Let Right(pRight As Currency)
    pShp.Left = pRight - pShp.Width
End Property

Property Get Top() As Currency
    Top = pShp.Top
End Property
Property Let Top(pTop As Currency)
    pShp.Top = pTop
End Property

Property Get Bottom() As Currency
    Bottom = pShp.Top + pShp.Height
End Property
Property Let Bottom(pBottom As Currency)
    pShp.Top = pBottom - pShp.Height
End Property
Property Get Width() As Currency
    Width = pShp.Width
End Property
Property Let Width(pWidth As Currency)
    pShp.Width = pWidth
End Property

Property Get Height() As Currency
    Height = pShp.Height
End Property
Property Let Height(pHeight As Currency)
    pShp.Height = pHeight
End Property
Public Sub Delete()
    pShp.Delete
End Sub

Property Get 速度角度() As Currency
    速度角度 = pVAngle
End Property
Public Sub SetV(速度 As Currency, 速度角度 As Currency)
    pV = 速度
    pVAngle = 速度角度
End Sub

Public Sub SetA(加速度 As Currency, 加速度角度 As Currency)
    pA = 加速度
    pAAngle = 加速度角度
End Sub

Public Sub Move()
    Me.X = Me.X + pV * Cos(pVAngle)
    Me.Y = Me.Y + pV * Sin(pVAngle)
    pV = Sqr((pV * Cos(pVAngle) + pA * Cos(pAAngle)) ^ 2 + (pV * Sin(pVAngle) + pA * Sin(pAAngle)) ^ 2)
    pVAngle = angle(pV * Cos(pVAngle) + pA * Cos(pAAngle), pV * Sin(pVAngle) + pA * Sin(pAAngle))
    
End Sub

Function angle(X As Currency, Y As Currency)
    Dim pHosei As Currency
    If Abs(X) < 0.001 Then
        If Y > 0 Then
            angle = PI / 2
        ElseIf Y < 0 Then
            angle = -PI / 2
        Else
            angle = PI / 2 '(;´▽｀A``
        End If
    Else
        If X > 0 Then
            If Y >= 0 Then pHosei = 0 Else pHosei = 2 * PI
        Else
            If Y >= 0 Then pHosei = PI Else pHosei = PI
        End If
        angle = Atn(Y / X)
    End If
    angle = angle + pHosei
End Function