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

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

原子の構造と電子配置④　けっこう作りました。

Powerpoint VBA

さて，ExcelVBAでクラスモジュール遊びを堪能したので，このブログの目的にもどります。

PowerpointVBAをとにかくたくさん書く。自分の備忘録にする。

あわよくば理科の教材を作る。

これが主たる目的。

だいぶ逸れてました(ﾟ▽ﾟ*)

chemiphys.hateblo.jp

これの続きです。

原子核描くのが大変だった～。うまいこと作れないのでごりごりトライアンドエラーでそれっぽさを求めました。

あと，とにかく無理をさせているぽく，よく強制終了の憂き目にあいます。ご注意ください。

まず，準備として，原子番号と質量数を与えないと，うまくいきませんので，必要な表を書くマクロを実行してください。元データ　という表を作ります。

chemiphys.hateblo.jp
これを使いました。使えましたよ!フォントサイズまでサポートさせていないので，表が縦に伸びますけど，きちんと表は作ってくれるはず。

原子模型作成というマクロを動かしてもらうと，作ります。止めるときはSTOPボタンで。

表作るマクロと合わせるとすごい長い標準モジュール(;´▽｀A``

f:id:chemiphys:20170205184935g:plain


表作成　で表を作って，　　原子模型作成　で動きます。

まっさらのパワーポイントに貼って動いたのを確認したので，たぶん動く・・はずです。



標準モジュール

Option Explicit
Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal ms As Long)
Const PI = 3.1415
Dim flgStop As Boolean

Sub 表作成()
Dim pSlide As Slide: Set pSlide = ActivePresentation.Slides(1)

   With pSlide.Shapes.AddTable(21, 2, 801.3029, 4.751811, 153.0709, 530.4964)
       .Name = "元データ"
        .Table.Cell(1, 1).Shape.TextFrame.TextRange = ""
        .Table.Cell(1, 1).Shape.Fill.ForeColor.RGB = 12874308
        .Table.Cell(1, 2).Shape.TextFrame.TextRange = "質量数"
        .Table.Cell(1, 2).Shape.Fill.ForeColor.RGB = 12874308
        .Table.Cell(2, 1).Shape.TextFrame.TextRange = "1H"
        .Table.Cell(2, 1).Shape.Fill.ForeColor.RGB = 15390159
        .Table.Cell(2, 2).Shape.TextFrame.TextRange = "1"
        .Table.Cell(2, 2).Shape.Fill.ForeColor.RGB = 15390159
        .Table.Cell(3, 1).Shape.TextFrame.TextRange = "2He"
        .Table.Cell(3, 1).Shape.Fill.ForeColor.RGB = 16116713
        .Table.Cell(3, 2).Shape.TextFrame.TextRange = "4"
        .Table.Cell(3, 2).Shape.Fill.ForeColor.RGB = 16116713
        .Table.Cell(4, 1).Shape.TextFrame.TextRange = "3Li"
        .Table.Cell(4, 1).Shape.Fill.ForeColor.RGB = 15390159
        .Table.Cell(4, 2).Shape.TextFrame.TextRange = "7"
        .Table.Cell(4, 2).Shape.Fill.ForeColor.RGB = 15390159
        .Table.Cell(5, 1).Shape.TextFrame.TextRange = "4Be"
        .Table.Cell(5, 1).Shape.Fill.ForeColor.RGB = 16116713
        .Table.Cell(5, 2).Shape.TextFrame.TextRange = "9"
        .Table.Cell(5, 2).Shape.Fill.ForeColor.RGB = 16116713
        .Table.Cell(6, 1).Shape.TextFrame.TextRange = "5B"
        .Table.Cell(6, 1).Shape.Fill.ForeColor.RGB = 15390159
        .Table.Cell(6, 2).Shape.TextFrame.TextRange = "11"
        .Table.Cell(6, 2).Shape.Fill.ForeColor.RGB = 15390159
        .Table.Cell(7, 1).Shape.TextFrame.TextRange = "6C"
        .Table.Cell(7, 1).Shape.Fill.ForeColor.RGB = 16116713
        .Table.Cell(7, 2).Shape.TextFrame.TextRange = "12"
        .Table.Cell(7, 2).Shape.Fill.ForeColor.RGB = 16116713
        .Table.Cell(8, 1).Shape.TextFrame.TextRange = "7N"
        .Table.Cell(8, 1).Shape.Fill.ForeColor.RGB = 15390159
        .Table.Cell(8, 2).Shape.TextFrame.TextRange = "14"
        .Table.Cell(8, 2).Shape.Fill.ForeColor.RGB = 15390159
        .Table.Cell(9, 1).Shape.TextFrame.TextRange = "8O"
        .Table.Cell(9, 1).Shape.Fill.ForeColor.RGB = 16116713
        .Table.Cell(9, 2).Shape.TextFrame.TextRange = "16"
        .Table.Cell(9, 2).Shape.Fill.ForeColor.RGB = 16116713
        .Table.Cell(10, 1).Shape.TextFrame.TextRange = "9F"
        .Table.Cell(10, 1).Shape.Fill.ForeColor.RGB = 15390159
        .Table.Cell(10, 2).Shape.TextFrame.TextRange = "19"
        .Table.Cell(10, 2).Shape.Fill.ForeColor.RGB = 15390159
        .Table.Cell(11, 1).Shape.TextFrame.TextRange = "10Ne"
        .Table.Cell(11, 1).Shape.Fill.ForeColor.RGB = 16116713
        .Table.Cell(11, 2).Shape.TextFrame.TextRange = "20"
        .Table.Cell(11, 2).Shape.Fill.ForeColor.RGB = 16116713
        .Table.Cell(12, 1).Shape.TextFrame.TextRange = "11Na"
        .Table.Cell(12, 1).Shape.Fill.ForeColor.RGB = 15390159
        .Table.Cell(12, 2).Shape.TextFrame.TextRange = "23"
        .Table.Cell(12, 2).Shape.Fill.ForeColor.RGB = 15390159
        .Table.Cell(13, 1).Shape.TextFrame.TextRange = "12Mg"
        .Table.Cell(13, 1).Shape.Fill.ForeColor.RGB = 16116713
        .Table.Cell(13, 2).Shape.TextFrame.TextRange = "24"
        .Table.Cell(13, 2).Shape.Fill.ForeColor.RGB = 16116713
        .Table.Cell(14, 1).Shape.TextFrame.TextRange = "13Al"
        .Table.Cell(14, 1).Shape.Fill.ForeColor.RGB = 15390159
        .Table.Cell(14, 2).Shape.TextFrame.TextRange = "27"
        .Table.Cell(14, 2).Shape.Fill.ForeColor.RGB = 15390159
        .Table.Cell(15, 1).Shape.TextFrame.TextRange = "14Si"
        .Table.Cell(15, 1).Shape.Fill.ForeColor.RGB = 16116713
        .Table.Cell(15, 2).Shape.TextFrame.TextRange = "28"
        .Table.Cell(15, 2).Shape.Fill.ForeColor.RGB = 16116713
        .Table.Cell(16, 1).Shape.TextFrame.TextRange = "15P"
        .Table.Cell(16, 1).Shape.Fill.ForeColor.RGB = 15390159
        .Table.Cell(16, 2).Shape.TextFrame.TextRange = "31"
        .Table.Cell(16, 2).Shape.Fill.ForeColor.RGB = 15390159
        .Table.Cell(17, 1).Shape.TextFrame.TextRange = "16S"
        .Table.Cell(17, 1).Shape.Fill.ForeColor.RGB = 16116713
        .Table.Cell(17, 2).Shape.TextFrame.TextRange = "32"
        .Table.Cell(17, 2).Shape.Fill.ForeColor.RGB = 16116713
        .Table.Cell(18, 1).Shape.TextFrame.TextRange = "17Cl"
        .Table.Cell(18, 1).Shape.Fill.ForeColor.RGB = 15390159
        .Table.Cell(18, 2).Shape.TextFrame.TextRange = "35"
        .Table.Cell(18, 2).Shape.Fill.ForeColor.RGB = 15390159
        .Table.Cell(19, 1).Shape.TextFrame.TextRange = "18Ar"
        .Table.Cell(19, 1).Shape.Fill.ForeColor.RGB = 16116713
        .Table.Cell(19, 2).Shape.TextFrame.TextRange = "40"
        .Table.Cell(19, 2).Shape.Fill.ForeColor.RGB = 16116713
        .Table.Cell(20, 1).Shape.TextFrame.TextRange = "19K"
        .Table.Cell(20, 1).Shape.Fill.ForeColor.RGB = 15390159
        .Table.Cell(20, 2).Shape.TextFrame.TextRange = "39"
        .Table.Cell(20, 2).Shape.Fill.ForeColor.RGB = 15390159
        .Table.Cell(21, 1).Shape.TextFrame.TextRange = "20Ca"
        .Table.Cell(21, 1).Shape.Fill.ForeColor.RGB = 16116713
        .Table.Cell(21, 2).Shape.TextFrame.TextRange = "40"
        .Table.Cell(21, 2).Shape.Fill.ForeColor.RGB = 16116713
    End With
End Sub

Sub 原子模型作成()
    Dim TargetSlide As Slide: Set TargetSlide = ActivePresentation.Slides(1)
    Dim s As Shape
    flgStop = False
    
    Do
        For Each s In TargetSlide.Shapes
            If s.Name <> "元データ" Then s.Delete
        Next
    Loop Until TargetSlide.Shapes.Count = 1

    With TargetSlide.Shapes.AddTextbox(msoTextOrientationHorizontal, 20, 20, 100, 50)
        .TextFrame.TextRange.Text = "STOP"
        .Fill.ForeColor.RGB = vbRed
        .ActionSettings(ppMouseClick).Action = ppActionRunMacro
        .ActionSettings(ppMouseClick).Run = "StopMacro"
    End With
    
    
    Dim 原子番号 As Long: 原子番号 = InputBox("原子番号?(1-18)N殻未実装")
    
    Call 原子核描画(原子番号, 300, 200)
    
    Dim AtomCore As ShpCls: Set AtomCore = New ShpCls
    AtomCore.SetShp TargetSlide.Shapes("原子核")
    
    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
                    半径 = 100 - 5: 色 = vbRed: 補正 = 0.5
                Case Is <= 10
                    半径 = 125 - 5: 色 = vbBlue: 補正 = 1
                Case Is > 10
                    半径 = 150 - 5: 色 = 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 = " "
        If flgStop = True Then Exit Do
        DoEvents
        Sleep 100
        j = j + 1
    Loop
    SlideShowWindows(1).View.Exit
End Sub
Sub StopMacro()
    flgStop = True
End Sub

Sub 原子核描画(原子番号 As Long, StartX As Long, StartY As Long)
Dim TargetSlide As Slide: Set TargetSlide = ActivePresentation.Slides(1)
Dim 粒子() As Shape, 粒子数 As Long
Dim i As Long, j As Long
Dim dX As Long, dY As Long
Dim R As Long


粒子数 = TargetSlide.Shapes("元データ").Table.Cell(原子番号 + 1, 2).Shape.TextFrame.TextRange

ReDim 粒子(粒子数)
i = 粒子数

Do
    Select Case i
        Case Is <= 4
            If i <= 4 Then R = 15
            dX = R * Cos(2 * PI / 4 * i)
            dY = R * Sin(2 * PI / 4 * i)
        Case Is <= 8
            R = 30
            dX = R * Cos(2 * PI / 4 * i + PI / 6)
            dY = R * Sin(2 * PI / 4 * i + PI / 6)
        Case Is <= 12
            R = 30
            dX = R * Cos(2 * PI / 4 * i + PI / 6 * 2)
            dY = R * Sin(2 * PI / 4 * i + PI / 6 * 2)
        Case Is <= 18
            R = 30
            dX = R * Cos(2 * PI / 4 * i)
            dY = R * Sin(2 * PI / 4 * i)
        Case Is <= 34
            If 粒子数 <= 22 Then R = 40 Else R = 45
            dX = R * Cos(2 * PI / 16 * 9 * i)
            dY = R * Sin(2 * PI / 16 * 9 * i)
        Case Else
            R = 55
            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, 30, 30)
    粒子(i).Fill.ForeColor.RGB = vbYellow
    粒子(i).ThreeD.BevelBottomDepth = 15
    粒子(i).ThreeD.BevelBottomInset = 15
    粒子(i).ThreeD.BevelTopDepth = 15
    粒子(i).ThreeD.BevelTopInset = 15
    粒子(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

With TargetSlide.Shapes.Range(Split(arr, vbTab)).Group
    .Name = "原子核"
End With

Dim ret As Long
j = 1
Do
    ret = Int(Rnd * 粒子数)
    If ret = 0 Then ret = 1
    If 粒子(ret).Fill.ForeColor.RGB = vbYellow Then
        粒子(ret).Fill.ForeColor.RGB = vbBlue
        j = j + 1
    End If
Loop Until j > 原子番号

End Sub

Sub 電子殻描画(原子番号 As Long, 原子核 As ShpCls)
    Dim TargetSlide As Slide: Set TargetSlide = ActivePresentation.Slides(1)
    
    With TargetSlide.Shapes.AddShape(msoShapeOval, 原子核.X - 100, 原子核.Y - 100, 200, 200)
        .Fill.Visible = msoFalse
        .Line.ForeColor.RGB = vbBlack
        .Name = "K殻"
    End With
    
    If 原子番号 > 2 Then
        With TargetSlide.Shapes.AddShape(msoShapeOval, 原子核.X - 125, 原子核.Y - 125, 250, 250)
            .Fill.Visible = msoFalse
            .Line.ForeColor.RGB = vbBlack
            .Name = "L殻"
        End With
        
        With TargetSlide.Shapes("K殻")
            .ZOrder msoSendToBack
            .Fill.ForeColor.RGB = RGB(255, 153, 153)
            .Fill.Visible = msoTrue
        End With
    End If
    
    If 原子番号 > 10 Then
        With TargetSlide.Shapes.AddShape(msoShapeOval, 原子核.X - 150, 原子核.Y - 150, 300, 300)
            .Fill.Visible = msoFalse
            .Line.ForeColor.RGB = vbBlack
        End With
        
        With TargetSlide.Shapes("L殻")
            .ZOrder msoSendToBack
            .Fill.ForeColor.RGB = RGB(255, 153, 51)
            .Fill.Visible = msoTrue
        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