化学反応式の量的関係 とりあえず完了
コードが長いです(;´▽`A``
正規表現を使っているのでMicrosoft VBScript Regular Expressions 5.5への参照設定が必要です。
コードが長すぎるため,最初に書きたいだけ書きます。
新規のプレゼンテーションに標準モジュールを追加し,そこにペタッと下記のコードを貼ります。
問題集作成マクロを実行すると,
こんなものが作られます。スライドショーを実行しましょう。
右側に並んでいる緑の番号を押すとその化学反応式が選ばれます。
そしたら,次の画面に移る。
5,7,9,11行目の白いセル?のどこかをクリックすると,そこに数値を入れれます。
画面切り替えを止めていないので,押せないところを押さないように気を付けましょう。スライドショーが終わりに向かいます。
マクロでやればよかったんですが,クリックしても画面切り替えしないように設定するといいと思われます。
表示を押すと,
表が埋まる。
数値は何度でも変えれるので,いろんな数値が試せます。個数の時は 6.0×10^23 なら 6e23 とか入力してください。
ツカレタ。。
マクロが長いせいか,なんにもなくてもパワーポイントが再起動することがあります。
このへんは,変わらないですね。。
どうしてなんでしょう( ´ー`)フゥー...
そうそう,個数はあまり物質量がとんでもない数値にならない程度で許してあげてください(;´▽`A``
全てを指数表示にしたら耐えれますが,今はそのようになっていません。
気体の体積は四捨五入した値がピンと来ない子が多いため,有効数字を他のものと統一していません。
けっこう適当な感じです(;´▽`A``
Const 行数 = 11, 列数 = 6, 行高さ = 49, 列幅 = 160 Const 原子量 = "H,1,C,12,N,14,O,16,Na,23,Mg,24,Al,27,P,31,S,32,K,39,Cl,35.5,Ca,40,Mn,55,Fe,56,Cu,64,Zn,65" Const NA As Single = 6# * 10 ^ 23 Sub 問題集作成() Dim Sld1 As Slide: Set Sld1 = ActivePresentation.Slides(1) Sld1.Shapes.Range.Delete If ActivePresentation.Slides.Count = 1 Then ActivePresentation.Slides.Add 2, ppLayoutBlank Dim 問題テーブル As Table With Sld1.Shapes.AddTable(11, 2) .Table.Columns(1).Width = 77 .Table.Columns(2).Width = 771 .Name = "問題テーブル" Set 問題テーブル = .Table Dim i For i = 1 To 10 .Table.Cell(1 + i, 1).Shape.TextFrame.TextRange.Text = i & ")" .Table.Rows(i + 1).Height = 46.5 .Table.Cell(1 + i, 2).Shape.TextFrame.VerticalAnchor = msoAnchorMiddle Next .Table.Cell(2, 2).Shape.TextFrame.TextRange.Text = "N2+3H2→2NH3" .Table.Cell(3, 2).Shape.TextFrame.TextRange.Text = "CH4+2O2→CO2+2H2O" .Table.Cell(4, 2).Shape.TextFrame.TextRange.Text = "2H2S+SO2→3S+2H2O" .Table.Cell(5, 2).Shape.TextFrame.TextRange.Text = "2Al+6HCl→2AlCl3+3H2" .Table.Cell(6, 2).Shape.TextFrame.TextRange.Text = "MnO2+4HCl→MnCl2+2H2O+Cl2" .Table.Cell(7, 2).Shape.TextFrame.TextRange.Text = "P4O10+6H2O→4H3PO4" .Table.Cell(8, 2).Shape.TextFrame.TextRange.Text = "4Al+3O2→2Al2O3" .Table.Cell(9, 2).Shape.TextFrame.TextRange.Text = "2KClO3→2KCl+3O2" .Table.Cell(10, 2).Shape.TextFrame.TextRange.Text = "C3H8+5O2→3CO2+4H2O" .Table.Cell(11, 2).Shape.TextFrame.TextRange.Text = "C2H5OH+3O2→2CO2+3H2O" .Left = 24 .Top = 10 End With For i = 1 To 10 With Sld1.Shapes.AddLabel(msoTextOrientationHorizontal, 878, 46.5 * i - 6, 44, 44) .TextFrame.AutoSize = ppAutoSizeNone .TextFrame.TextRange.Text = i .TextFrame.TextRange.ParagraphFormat.Alignment = ppAlignCenter .TextFrame.VerticalAnchor = msoAnchorMiddle .Fill.ForeColor.RGB = rgbGreen .Name = "変更ボタン " & i .ActionSettings(ppMouseClick).Action = ppActionRunMacro .ActionSettings(ppMouseClick).Run = "問題変更" End With Next With Sld1.Shapes.AddLabel(msoTextOrientationHorizontal, 878, 0, 44, 44) .TextFrame.AutoSize = ppAutoSizeNone .TextFrame.TextRange.Text = "編集" .TextFrame.TextRange.Font.Color.RGB = rgbBlack .TextFrame.TextRange.ParagraphFormat.Alignment = ppAlignCenter .TextFrame.VerticalAnchor = msoAnchorMiddle .Fill.ForeColor.RGB = rgbYellow .Name = "問題編集" .ActionSettings(ppMouseClick).Action = ppActionRunMacro .ActionSettings(ppMouseClick).Run = "問題編集" End With Dim Reg As New RegExp, Matches As MatchCollection With Reg .Global = True .Pattern = "[A-Za-z][0-9]+" End With Dim j For j = 2 To 11 Set Matches = Reg.Execute(問題テーブル.Cell(j, 2).Shape.TextFrame.TextRange.Text) For i = 0 To Matches.Count - 1 問題テーブル.Cell(j, 2).Shape.TextFrame.TextRange.Characters(Matches(i).FirstIndex + 2, Matches(i).Length - 1).Font.Subscript = True Next Next End Sub Sub 問題変更(TShp As Shape) Dim Sld1 As Slide: Set Sld1 = ActivePresentation.Slides(1) Dim Sld2 As Slide: Set Sld2 = ActivePresentation.Slides(2) Dim Val(1 To 11, 1 To 6) As String Dim 化学反応式 As String, n As Long n = CLng(Split(TShp.Name)(1)) + 1 化学反応式 = Sld1.Shapes("問題テーブル").Table.Cell(n, 2).Shape.TextFrame.TextRange.Text Dim Reg As New RegExp Dim 係数Matches As MatchCollection, 化合物Matches As MatchCollection ', 係数抜きMatches As MatchCollection With Reg .Global = True .Pattern = "[\+→]([0-9]*)" Set 係数Matches = .Execute("+" & 化学反応式) .Pattern = "([0-9]*)([A-Z][a-z]?[A-Za-z0-9]*)" Set 化合物Matches = .Execute(化学反応式) End With Call 表作成 Dim 矢印 As String, i As Long, j As Long, 係数 As String For i = 0 To 化合物Matches.Count - 1 Val(1, i + 2) = 化合物Matches(i) 係数 = 化合物Matches(i).SubMatches(0) If 係数 = "" Then 係数 = 1 Val(2, i + 2) = Switch(係数 = "", 1, 係数 <> "", CLng(係数)) Val(3, i + 2) = 式量(化合物Matches(i).SubMatches(1)) Next For i = 1 To 11 For j = 2 To 6 If Val(1, j) = "" Then Sld2.Shapes(i & " " & j).Visible = msoFalse Else Sld2.Shapes(i & " " & j).Visible = msoTrue Next Next For i = 1 To 係数Matches.Count - 1 '1スタートは最初無視するため 矢印 = 矢印 & Left(係数Matches(i), 1) Next Call 矢印作成(矢印) Dim k, Matches As MatchCollection For j = 2 To 6 For i = 1 To 3 Sld2.Shapes(i & " " & j).TextFrame.TextRange.Text = Val(i, j) Next With Reg .Pattern = "[A-Za-z][0-9]+" Set Matches = .Execute(Val(1, j)) End With For k = 0 To Matches.Count - 1 Sld2.Shapes(1 & " " & j).TextFrame.TextRange.Characters(Matches(k).FirstIndex + 2, Matches(k).Length - 1).Font.Subscript = True Next Next End Sub Sub 問題編集() Dim i i = InputBox("何番の問題を編集しますか? [1-10]") If IsNumeric(i) = False Then MsgBox ("番号が入力されなかったため,終了します。") Exit Sub Else i = CLng(i) End If Dim str, TRng As TextRange Dim Sld1 As Slide: Set Sld1 = ActivePresentation.Slides(1) Set TRng = Sld1.Shapes("問題テーブル").Table.Cell(i + 1, 2).Shape.TextFrame.TextRange str = InputBox("問題を入力してください。+は半角,→は全角の矢印で。", , TRng.Text) If str <> "" Then TRng.Text = str Dim Reg As New RegExp With Reg .Global = True .Pattern = "[A-Za-z][0-9]+" Set Matches = .Execute(str) End With For i = 0 To Matches.Count - 1 TRng.Characters(Matches(i).FirstIndex + 2, Matches(i).Length - 1).Font.Subscript = True Next End Sub Sub 表作成() Dim Sld2 As Slide: Set Sld2 = ActivePresentation.Slides(2) Dim Val(1 To 11, 1 To 6) As String Dim タイトル, 色, 文字色 タイトル = Array("", "係数", "分子量・式量", "物質量の計算", "物質量(mol)", "個数の計算", "個数(個)", "質量の計算", "質量(g)", "気体の体積計算", "気体の体積(L)") 色 = Array(rgbBlack, rgbLavender, rgbKhaki, rgbLightSteelBlue, rgbWhite, rgbLightSteelBlue, rgbWhite, rgbLightSteelBlue, rgbWhite, rgbLightSteelBlue, rgbWhite) 文字色 = Array(rgbWhite, rgbBlack, rgbDarkGreen, rgbBlack, rgbRed, rgbBlack, rgbBlack, rgbBlack, rgbBlack, rgbBlack, rgbBlack) Sld2.Shapes.Range.Delete Sld2.Layout = ppLayoutBlank Dim i, j For i = 0 To 行数 - 1 For j = 0 To 列数 - 1 With Sld2.Shapes.AddLabel(msoTextOrientationHorizontal, j * 列幅, i * 行高さ, 列幅, 行高さ) .Name = i + 1 & " " & j + 1 With .TextFrame .AutoSize = ppAutoSizeNone .WordWrap = msoTrue .TextRange.Font.Color.RGB = 文字色(i) If j = 0 Then .TextRange.Text = タイトル(i) End With .Fill.ForeColor.RGB = 色(i) 'Switch(j = 0, rgbGreen, j <> 0, 色(i)) If i = 4 Or i = 6 Or i = 8 Or i = 10 Then With .ActionSettings(ppMouseClick) .Action = ppActionRunMacro .Run = "編集" End With End If End With Next Next With Sld2.Shapes.AddLabel(msoTextOrientationHorizontal, 0, 0, 列幅 / 2, 行高さ) .TextFrame.AutoSize = ppAutoSizeNone .TextFrame.TextRange.Text = "表示" .Fill.ForeColor.RGB = rgbRed With .ActionSettings(ppMouseClick) .Action = ppActionRunMacro .Run = "表示" End With End With With Sld2.Shapes.AddLabel(msoTextOrientationHorizontal, 列幅 / 2, 0, 列幅 / 2, 行高さ) .TextFrame.AutoSize = ppAutoSizeNone .TextFrame.TextRange.Text = "変更" .Fill.ForeColor.RGB = rgbRed With .ActionSettings(ppMouseClick) .Action = ppActionFirstSlide End With End With With Sld2.Shapes.Range .Line.Weight = 1.5 .Line.ForeColor.RGB = rgbBlack With .TextFrame .VerticalAnchor = msoAnchorMiddle .HorizontalAnchor = msoAnchorCenter .MarginLeft = 2 .MarginRight = 2 With .TextRange.Font .Name = "Meiryo UI" .Bold = msoTrue .Size = 24 End With End With End With 'Fontサイズ微調整 For j = 2 To 6 Sld2.Shapes(6 & " " & j).TextFrame.TextRange.Font.Size = 18 Next Sld2.Shapes("10 1").TextFrame.TextRange.Font.Size = 20 Sld2.Shapes("11 1").TextFrame.TextRange.Font.Size = 20 'ここまで SlideShowWindows(Index:=1).View.GotoSlide Index:=2 End Sub Sub 編集(TShp As Shape) Dim Sld2 As Slide: Set Sld2 = ActivePresentation.Slides(2) 'Dim TShp As Shape: Set TShp = Sld2.Shapes("7 2") 'デバッグ用 Dim TargetI, TargetJ, ret TargetI = Split(TShp.Name)(0) TargetJ = Split(TShp.Name)(1) ret = InputBox("値を入力 個数は 数値E指数 の形で") If IsNumeric(ret) = False Then Exit Sub Dim Val(1 To 11, 1 To 6) As Variant, i As Long, j As Long, tmp As Variant Val(TargetI, TargetJ) = CSng(ret) For i = 2 To 3 For j = 2 To 6 tmp = Sld2.Shapes(i & " " & j).TextFrame.TextRange.Text If tmp <> "" Then Val(i, j) = CSng(tmp) Next Next Sld2.Shapes("1 1").TextFrame.TextRange.Text = TargetI & " " & TargetJ Select Case TargetI Case Is = 5 Val(1, TargetJ) = CSng(ret) Case Is = 7 Val(1, TargetJ) = CSng(ret) / NA Case Is = 9 Val(1, TargetJ) = CSng(ret) / CSng(Val(3, TargetJ)) Case Is = 11 Val(1, TargetJ) = CSng(ret) / 22.4 End Select For j = 2 To 6 If Val(2, j) <> "" Then Val(1, j) = Val(1, TargetJ) / Val(2, TargetJ) * Val(2, j) Val(5, j) = 有効数字表示(Val(1, j), 2, False) Val(4, j) = 有効数字表示(Val(5, TargetJ), 2, False) & "÷" & Val(2, TargetJ) & "×" & Val(2, j) End If Next For j = 2 To 6 If Val(2, j) <> "" Then Val(6, j) = "6.0×1023×" & Val(5, j) Val(7, j) = 有効数字表示(NA * CSng(Val(1, j)), 2, True) Val(8, j) = Val(3, j) & "×" & Val(5, j) Val(9, j) = 有効数字表示(Val(3, j) * CSng(Val(1, j)), 2, False) Val(10, j) = "22.4×" & Val(5, j) Val(11, j) = 有効数字表示(22.4 * CSng(Val(1, j)), 3, False) End If Next Call 消去 Dim 色 As Variant, 開始 As Long, 長さ As Long 色 = Array(rgbBlack, rgbLavender, rgbKhaki, rgbLightSteelBlue, rgbWhite, rgbLightSteelBlue, rgbWhite, rgbLightSteelBlue, rgbWhite, rgbLightSteelBlue, rgbWhite) For i = 4 To 11 For j = 2 To 6 If Val(i, j) <> "" Then With Sld2.Shapes(i & " " & j).TextFrame .TextRange = Val(i, j) .TextRange.Font.Color.RGB = 色(i - 1) If i = 7 Then tmp = Val(7, j) 開始 = InStr(tmp, "^") 長さ = Len(tmp) - 開始 .TextRange.Font.Superscript = msoFalse .TextRange.Text = Replace(tmp, "^", "") .TextRange.Characters(開始, 長さ).Font.Superscript = msoTrue End If End With End If Next Next Sld2.Shapes(TargetI & " " & TargetJ).TextFrame.TextRange.Font.Color.RGB = rgbRed End Sub Sub 表示() Dim TargetI As Long, TargetJ As Long, i As Long, j As Long, k As Long, tmp As String Dim Val(1 To 11, 2 To 6) As Variant Dim Sld2 As Slide: Set Sld2 = ActivePresentation.Slides(2) tmp = Sld2.Shapes("1 1").TextFrame.TextRange.Text TargetI = Split(tmp)(0) TargetJ = Split(tmp)(1) For i = 2 To 11 For j = 2 To 6 Val(i, j) = Sld2.Shapes(i & " " & j).TextFrame.TextRange.Text If i = 7 Then For k = 1 To Len(Val(7, j)) If Sld2.Shapes("7 " & j).TextFrame.TextRange.Characters(k).Font.Superscript = msoTrue Then Val(7, j) = Left(Val(7, j), k - 1) & "^" & Mid(Val(7, j), k) Exit For End If Next End If Next Next Dim 物質量元文字数 As Long, 物質量文字数 As Long, 係数元文字数 As Long, 係数文字数 As Long, 開始 As Long, 長さ As Long 物質量元文字数 = Len(Val(5, TargetJ)) 係数元文字数 = Len(Val(2, TargetJ)) For i = 1 To 11 For j = 2 To 6 With Sld2.Shapes(i & " " & j) If Val(2, j) <> "" Then If i = TargetI And j = TargetJ Then .Fill.ForeColor.RGB = rgbYellow .TextFrame2.TextRange.Font.Highlight = rgbYellow End If 物質量文字数 = Len(Val(5, j)) 係数文字数 = Len(Val(2, j)) tmp = Val(i, j) Select Case i Case Is = 2 .TextFrame.TextRange.Font.Color.RGB = rgbBlack If j = TargetJ Then .TextFrame2.TextRange.Font.Highlight = rgbLime Case Is = 3 .TextFrame.TextRange.Font.Color.RGB = rgbDarkGreen Case Is = 4 With .TextFrame.TextRange .Font.Color.RGB = rgbBlack .Characters(1, 物質量元文字数).Font.Color.RGB = rgbBlue End With .TextFrame2.TextRange.Characters(1, InStr(tmp, "÷") - 1).Font.Highlight = rgbYellow .TextFrame2.TextRange.Characters(物質量元文字数 + 2, 係数元文字数).Font.Highlight = rgbLime Case Is = 5 If j = TargetJ Then .TextFrame.TextRange.Font.Color.RGB = rgbBlack .Fill.ForeColor.RGB = rgbYellow .TextFrame2.TextRange.Font.Highlight = rgbYellow End If With .TextFrame.TextRange .Font.Color.RGB = rgbRed If j = TargetJ Then .Font.Color.RGB = rgbBlue End With Case Is = 6 With .TextFrame.TextRange .Font.Color.RGB = rgbBlack .Characters(7, 2).Font.Superscript = msoTrue .Characters(10, 物質量文字数).Font.Color.RGB = Switch(j <> TargetJ, rgbRed, j = TargetJ, rgbBlue) End With Case Is = 7 With .TextFrame.TextRange .Font.Color.RGB = rgbBlack tmp = Val(7, j) 開始 = InStr(tmp, "^") 長さ = Len(tmp) - 開始 .Font.Superscript = msoFalse .Text = Replace(tmp, "^", "") .Characters(開始, 長さ).Font.Superscript = msoTrue End With Case Is = 8, 10 With .TextFrame.TextRange .Font.Color.RGB = rgbBlack If i = 8 Then .Characters(1, Len(Val(3, j))).Font.Color.RGB = rgbGreen 開始 = InStr(tmp, "×") 長さ = Len(tmp) - 開始 .Characters(開始 + 1, 長さ).Font.Color.RGB = Switch(j <> TargetJ, rgbRed, j = TargetJ, rgbBlue) End With Case Is = 9, 11 .TextFrame.TextRange.Font.Color.RGB = rgbBlack End Select End If End With Next j Next i Sld2.Shapes(TargetI & " " & TargetJ).TextFrame.TextRange.Font.Color.RGB = rgbRed End Sub Sub 矢印作成(Val As String) Dim Sld2 As Slide: Set Sld2 = ActivePresentation.Slides(2) Dim i For i = 1 To Len(Val) If Mid(Val, i, 1) = "+" Then With Sld2.Shapes.AddShape(msoShapeCross, 列幅 * (i + 1) - 12.5, 15, 25, 25) .Adjustments(1) = 0.4 .Fill.ForeColor.RGB = rgbWhite End With Else With Sld2.Shapes.AddShape(msoShapeRightArrow, 列幅 * (i + 1) - 12.5, 17.5, 25, 20) .Adjustments(1) = 0.3 .Adjustments(2) = 0.4 .Fill.ForeColor.RGB = rgbWhite End With End If Next End Sub Sub 消去() Dim Sld2 As Slide: Set Sld2 = ActivePresentation.Slides(2) Dim タイトル, 色, 文字色 タイトル = Array("", "係数", "分子量・式量", "物質量の計算", "物質量(mol)", "個数の計算", "個数(個)", "質量の計算", "質量(g)", "気体の体積計算", "気体の体積(L)") 色 = Array(rgbBlack, rgbLavender, rgbKhaki, rgbLightSteelBlue, rgbWhite, rgbLightSteelBlue, rgbWhite, rgbLightSteelBlue, rgbWhite, rgbLightSteelBlue, rgbWhite) 文字色 = Array(rgbWhite, rgbBlack, rgbDarkGreen, rgbBlack, rgbRed, rgbBlack, rgbBlack, rgbBlack, rgbBlack, rgbBlack, rgbBlack) Dim i, j For i = 2 To 11 For j = 2 To 6 With Sld2.Shapes(i & " " & j) .Fill.ForeColor.RGB = 色(i - 1) .TextFrame2.TextRange.Font.Highlight = .Fill.ForeColor.RGB With .TextFrame.TextRange If i > 3 Then .Text = "" With .Font .Color.RGB = 文字色(i - 1) .Superscript = msoFalse End With End With End With Next Next End Sub Function 式量(化学式 As String) As Single Dim arr原子量 As Variant arr原子量 = Split(原子量, ",") Dim Reg As New RegExp, Matches As MatchCollection With Reg .Global = True .Pattern = "([A-Z][a-z]?)([0-9]*)" Set Matches = .Execute(化学式) End With Dim i, j, 原子量_ As Single, 原子 As String, tmp As String, 添え字 As Long For i = 0 To Matches.Count - 1 原子 = Matches(i).SubMatches(0) For j = 0 To UBound(arr原子量) - 2 Step 2 If 原子 = arr原子量(j) Then 原子量_ = CSng(arr原子量(j + 1)) Next tmp = Matches(i).SubMatches(1) If tmp = "" Then 添え字 = 1 Else 添え字 = CLng(tmp) 式量 = 式量 + 原子量_ * 添え字 Next End Function Function 個数(ByVal 物質量 As Single) As Single 個数 = 物質量 * NA End Function Function 質量(ByVal 物質量 As Single, モル質量 As Long) As Single 質量 = 物質量 * モル質量 End Function Function 体積(ByVal 物質量 As Single) As Single 体積 = 物質量 * 22.4 End Function Function 物質量_個数(ByVal 個数 As Single) As Single 物質量_個数 = 個数 / NA End Function Function 物質量_質量(ByVal 質量 As Single, モル質量 As Long) As Single 物質量_質量 = 質量 / モル質量 End Function Function 物質量_体積(ByVal 体積 As Single) As Single 物質量_個数 = 体積 / 22.4 End Function Function 有効数字表示(値 As Variant, 桁 As Long, 指数表示 As Boolean) As String Dim Val_ As String, Format_ As String If 桁 = 1 Then Format_ = "0" Else Format_ = "0." & String(桁 - 1, "0") & "e-0" Val_ = Format(CSng(値), Format_) If 指数表示 = True Then 有効数字表示 = Replace(Val_, "e", "×10^") Else 有効数字表示 = CSng(Left(Val_, InStr(Val_, "e") - 1) & "e" & Mid(Val_, InStr(Val_, "e") + 1)) If InStr(有効数字表示, "E") = 0 Then Dim 数値スタート As Long, i As Long, 数値桁 As Long For i = 1 To Len(有効数字表示) If Mid(有効数字表示, i, 1) <> "0" And Mid(有効数字表示, i, 1) <> "." Then 数値スタート = i Exit For End If Next 数値桁 = Len(有効数字表示) - 数値スタート + 1 If 桁 > 数値桁 Then If Len(有効数字表示) = 1 Then 有効数字表示 = 有効数字表示 & "." 有効数字表示 = 有効数字表示 & String(桁 - 数値桁, "0") End If End If End If End Function