トグル入力のコード Excel VBA
ブログ名前詐欺中です。 今取り組んでることのための部品。
キーボードを使わずタブレットだけで作業をする。
複雑なインターフェースは準備できない。 でも簡単な入力方法を実装したい。
いつも思いつくのは，お風呂に入ってるときや，帰宅，出勤時。
考えを変えるタイミングって大事ですね。
さて，とても単純なヤツデス。
Sub クリック入力(Add As String, Min As Long, Max As Long) Dim Rng As Range: Set Rng = ActiveSheet.Range(Add) Rng.Value = Rng.Value + 1 If Rng.Value > Max Then Rng.Value = Min End Sub Sub Sht1_E5() Call クリック入力("e5", 0, 5) End Sub Sub Sht1_E6() Call クリック入力("e6", 0, 1) End Sub
(´▽`) '`,、'`,、 ミジカイ
私は雑な人間ですが，さすがに，上のSSはわざとちょっとずれてるのをスルーしています。
E5,E6のセル上にボタンにするための透明な図形をのせて，それらに Sht1_E5 Sht1_E6をマクロ登録しています。
動画とらないで大丈夫ですよね。。あまりにも短いコードですから。。
クリックするたびに数値が１ずつ増え，最大値を超えると最小値になるよ，というコードです。
Excelのリスト入力は便利なんですけど，キーボードやマウスが使えない時ってあれってかなりちっちゃい。
その時のためのインターフェースとして考えてみました。明日実装してみよう。。
毎年この時期はデータ処理。。
教員をしていると，入試の時期が必ず来ます。
そろそろ，また今年の分の調整をし始めないといけません。
思えば，様々なアドバイスをいただき始めたのも，データ処理をどうするか，という話の頃から。
とてもありがたいことです。以前とはコードの書き方もけっこう変化しました。
そして，私はいつも同じ付近に考え方を戻して，いろんなことを気分でやるので，今回はある意味ふりだしに戻った感が否めません。
ですが，VBA組める同僚はほとんど出会わない職場ですので，他の人でも見てわかる，とか，自分が中身を忘れてもみればわかる・・・
そのようなものを求めるのもしょうがないのかなぁと思います。
Infomentさんのブログで配列のソートに取り組まれています。
PowerPointでものづくりをするときは否応なしにそっち方向でやっていかないといけないので，とても楽しみに様子を見させてもらってます。
わたしは，とりあえず今年は一時ワークシートを作ってそこで作業する，という方向に戻して考えようということにしました。
Stopでもそのあたりに入れておけば，ソートの途中経過など確認しやすいから，というのもありますね。
とりあえずてきとーに組んだのがこちら。Excel VBAです。
Function ソート(ソース As Variant, ParamArray Keys()) As Variant Dim Data As Variant, 行数 As Long, 列数 As Long If TypeName(ソース) = "Range" Then 行数 = ソース.Rows.Count 列数 = ソース.Columns.Count Data = ソース.Value Else 行数 = UBound(ソース, 1) 列数 = UBound(ソース, 2) Data = ソース End If Dim TempSht As Worksheet Set TempSht = ThisWorkbook.Worksheets.Add Dim s As Worksheet, No As Long, flg As Boolean Do No = No + 1 flg = False For Each s In ThisWorkbook.Worksheets If s.Name = "作業用一時シート" & Format(No, "00") Then flg = True Next Loop Until flg = False TempSht.Name = "作業用一時シート" & Format(No, "00") Dim SObj As Sort, TempRng As Range, i As Long, j As Long Set TempRng = TempSht.Range(TempSht.Cells(1, 1), TempSht.Cells(行数, 列数)) TempRng.Value = Data Set SObj = TempSht.Sort With SObj .SortFields.Clear .SetRange TempRng .Header = xlYes For i = 0 To UBound(Keys) - 1 Step 2 .SortFields.Add Key:=TempRng.Cells(1, Keys(i)), Order:=Switch(Keys(i + 1) = True, xlAscending, Keys(i + 1) = False, xlDescending) Next .Apply End With ソート = TempRng.Value Application.DisplayAlerts = False TempSht.Delete Application.DisplayAlerts = True End Function Function 抽出(ソース As Variant, flg As Variant, ParamArray Keys()) As Variant Dim i As Long, j As Long, k As Long, l As Long, Flg2 As Boolean Dim 行数 As Long, 列数 As Long, tmp() As Variant 行数 = UBound(ソース, 1) 列数 = UBound(ソース, 2) If flg = True Then ReDim tmp(1 To 行数, 1 To UBound(Keys) + 1) For i = 1 To UBound(ソース, 1) k = 1 For l = 0 To UBound(Keys) tmp(i, k) = ソース(i, Keys(l)) k = k + 1 Next l Next i Else ReDim tmp(1 To 行数, 1 To 列数 - UBound(Keys) - 1) k = 1 For j = 1 To UBound(ソース, 2) Flg2 = True For l = 0 To UBound(Keys) If j = Keys(l) Then Flg2 = False Next If Flg2 = True Then For i = 1 To UBound(ソース, 1) tmp(i, k) = ソース(i, j) Next k = k + 1 End If Next End If 抽出 = tmp End Function Sub テスト() Dim ret As Variant ret = 抽出(ソート(Sheet1.Range("a1").CurrentRegion, 8, True, 5, True), True, 5, 6, 7, 9) Sheet4.Cells(1, 1).Resize(UBound(ret, 1), UBound(ret, 2)).Value = ret Stop End Sub Sub テスト2() Dim a As Variant: a = Sheet1.Range("a1").CurrentRegion.Value Dim b As Variant: b = 抽出(a, False, 2, 3) Stop End Sub
自分用メモが主のブログでもありますので，説明とかいろいろと省きまくりなのはスルーしてほしいところです。
一時シートをつくり，そこにデータを放り込んでソートオブジェクトにおまかせ，というやつです。
あと，ソートの結果の一部を利用したり，または，ほとんど利用するんだけど，数列分は消したいという作業をよくやるので，抽出する関数も用意しています。
Sheet1のデータを取り込んで，一部抽出したり，ソート結果をさらに抽出する，という作業を テスト や テスト2
とかでやってみてますが，見た目にはまともに動いてそうでした。。
結局，速いアルゴリズムが優れたソートを自分はあまり実装できず，できてバブルソートだったりするので，
ExcelならSortオブジェクト使い倒してしまえ，という気分で作ったものです。
いくつキー与えてもやってくれるし，このマクロ組んでたら，Sortにcustomorderが使えるというのに今更ながらに知って驚いたり，
やっぱりいろいろと気楽にやってみるもんだなぁと思ったところです。。
－－
わたしがいる学校ではそろそろ文化祭。
同僚に突然仕事を振られて，準備期間ほんのちょっとなのに 販売で使うシステムを組まされたりしています。
かなり以前に，小さなテキストメモみたいなものを吐き出して共通に見れるフォルダに放り込み，それをデータとして使う，，というシステムを作ったことがありました。
きちんとルール作りをすれば，データはその1KB程度のテキストがたくさん存在するだけであり，Excelが固まってもデータはほとんど消えることなく，
システムも小さくて済む。とても気楽に多人数でデータを扱えるシステムができている気がしています。
まさかこんなところで日の目を見るとは思わないものづくりでしたが，いつどんなものが役に立つかわからないものだなぁと思う。
思いつきは役に立とうが立つまいが一度は形にして，蓄積していけばいつか時間がないときにささっと対応できるなぁ，と２年ほど前の自分をほめつつ，
極めて短い準備期間なので，不具合をとても不安にも思いつつ作業しているところです。。
ひと段落しています。(VBAコード一切ありません)
とりあえず，作った教材を紹介する，という機会が終わりました。
仕事で人にものを説明することを日々やっている割に，やはり緊張するものですね。
また，PowerPoint2016のノートPCとPowerPoint2013のタブレットで動作確認をし，さらに直前に，
説明する電子黒板と同じ状態であろう，隣の部屋の電子黒板で動くことを確認していたのに，
実際説明するとき(PowerPoint2013でした)，途中でマクロが止まってΣ(･ω･ﾉ)ﾉ！びっくりしました。
こういうとこは，さすが自分だな・・(;´▽｀A``と思う次第。。
疑問なのは，普段スライドショーの完遂が優先され，コードエラーを直接吐かず沈黙するPowerPointが
エラーを吐いて止まったこと。。
どういう状態だったのか興味があります。確かめようはありませんが。。
いい経験ですね。やはり，動かす機械で確認をとっておかないといけないです。
一部，思い通りにいかなかったとはいえ，その部分はどちらかといえば枝葉の部分で主幹部分ではなかったので，
軽くスルーしてしまいました。
自分の適当さをそこでも感じたところです。
・・・
終わったし，何かまた何か作ってみよう。何に手を出そうか。。
( ´ー｀)ﾌｩｰ．．．
有効数字 今度こそ大丈夫??
まだ変なとこありましたので，書き直してみた。
うーん。なんと面倒な。。気にせずやれればいいんですが(;´▽｀A`` 固定小数点でやれない数値の扱いって面倒ですね。
できるだけシンプルな方法を今後も考えます。主目的がここじゃないせいで，トライアンドエラーでしかやってない(;´▽｀A``
Function 有効数字表示(値 As Variant, 桁 As Long, 指数表示 As Boolean) As String Dim Val_ As String, Format_ As String If 桁 = 1 Then Format_ = "0e-0" Else Format_ = "0." & String(桁 - 1, "0") & "e-0" Val_ = Format(CSng(値), Format_) If 指数表示 = True Then 有効数字表示 = Replace(Val_, "e", "×10^") Else Dim 数値部分, 桁部分, tmp, tmp2, tmp3, tmp4 数値部分 = Left(Val_, InStr(Val_, "e") - 1) 桁部分 = Mid(Val_, InStr(Val_, "e") + 1) 有効数字表示 = CSng(数値部分 & "e" & 桁部分) If 桁 = 1 Then Exit Function If InStr(有効数字表示, "E") = 0 Then If InStr(有効数字表示, ".") > 0 Then tmp = Len(有効数字表示) - 1 Else tmp = Len(有効数字表示) tmp = Format(CSng(数値部分) / CSng(有効数字表示), "0e-0") tmp2 = Replace(数値部分, ".", "") tmp3 = Mid(tmp, InStr(tmp, "e") + 1) Select Case tmp3 Case Is = 0 有効数字表示 = 数値部分 Case Is > 0 If tmp = 1 Then 有効数字表示 = "0." & tmp2 Else 有効数字表示 = "0." & String(tmp3 - 1, "0") & tmp2 End If Case Is < 0 tmp4 = Len(有効数字表示) If tmp4 < 桁 Then 有効数字表示 = 有効数字表示 & "." & String(桁 - tmp4, "0") End If End Select End If End If End Function
ちまちま確かめていると，間違いに気づかないのでExcelにこのFunctionを放り込んでチェック
大丈夫そうだけどなぁ(;´▽｀A``
有効数字 修正をはじめてます。
有効数字を処理する部分がまずそうだったので修正中です。
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
数値桁 = Len(有効数字表示) - 数値スタート + 1
If 桁 > 数値桁 Then
If Len(有効数字表示) = 1 Then 有効数字表示 = 有効数字表示 & "."
有効数字表示 = 有効数字表示 & String(桁 - 数値桁, "0")
End If
最後当たりのこの辺がうまくいっていません。
考え中。
追記
とりあえず，トライアンドエラーでいじってみました。
フローチャートを書いて根元から考えようとしないヤツですみません(;´▽｀A``
Function 有効数字表示(値 As Variant, 桁 As Long, 指数表示 As Boolean) As String Dim Val_ As String, Format_ As String If 桁 = 1 Then Format_ = "0e-0" Else Format_ = "0." & String(桁 - 1, "0") & "e-0" Val_ = Format(CSng(値), Format_) If 指数表示 = True Then 有効数字表示 = Replace(Val_, "e", "×10^") Else Dim 数値部分, 桁部分, tmp, tmp2 数値部分 = Left(Val_, InStr(Val_, "e") - 1) 桁部分 = Mid(Val_, InStr(Val_, "e") + 1) 有効数字表示 = CSng(数値部分 & "e" & 桁部分) If 桁 = 1 Then Exit Function If InStr(有効数字表示, "E") = 0 Then If InStr(有効数字表示, ".") > 0 Then tmp = Len(有効数字表示) - 1 Else tmp = Len(有効数字表示) tmp = Format(CSng(数値部分) / CSng(有効数字表示), "0e-0") tmp = Mid(tmp, InStr(tmp, "e") + 1) tmp2 = Replace(数値部分, ".", "") Select Case tmp Case Is = 0 有効数字表示 = 数値部分 Case Is > 0 If tmp = 1 Then 有効数字表示 = "0." & tmp2 Else 有効数字表示 = "0." & String(tmp - 1, "0") & tmp2 End If Case Is < 0 有効数字表示 = Left(tmp2, 1 - CLng(tmp)) & "." & Mid(tmp2, 2 - CLng(tmp)) If Right(有効数字表示, 1) = "." Then 有効数字表示 = Left(有効数字表示, Len(有効数字表示) - 1) End Select End If End If End Function
イミディエイトウィンドウでいろいろやってみた感じはいけそうなんだけど・・，さすがに何度も間違ったのでまだ疑っています(;´▽｀A``
あとあきらかに美しくないので，きちんと統合していこうと思います。
化学反応式の量的関係 とりあえず完了
コードが長いです(;´▽｀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
powerpoint vba はみ出すテキストの処理 (現状失敗)
なかなか厄介なものに出会って困っています。これも解決へ持っていけるのか，はたまた代替案を持っていくのか。
PowerpointのVBAってスライドショー中にいらないことをさせないって考え方でもあるのかなぁ。( ´ー｀)ﾌｩｰ．．．
ぶつかっている壁は単純だからこそ厄介な感じです。
コードは準備していません。ひとつテキストボックスを加えて，わざとはみ出るようにしています。
編集モードにおいて イミディエイトウィンドウで下記のコードを実行すると，
activepresentation.Slides(1).Shapes(1).TextFrame2.AutoSize=msoAutoSizeTextToFitShape
想定通りちゃんとテキストに文字がおさまり，
こちらを実行すると，元に戻ります。
activepresentation.Slides(1).Shapes(1).TextFrame2.AutoSize=msoAutoSizeNone
よしよし，コードはこれでよさそうだなぁ・・と，スライドショー中にやると，
msoAutoSizeNoneで解除することはできても， msoAutoSizeTextToFitShapeのほうはガン無視されてしまいます。!?(ﾟ〇ﾟ;)
ここで解除だけうまく働くところも私的には罠としか思えない。両方動かないなら長時間うんうん悩まないで済むのに。。
なかなかこれは厄介で，もうしばらく考えて無理なら 文字数でフォントサイズを変化させるように作るしか無いなぁと逃げを考えています。
なんなんでしょうね。。
あと，いくつもPowerpointのプレゼンファイルを開いたまま操作したりするので，今更ながら， ThisPresentation ってオブジェクトはなんでないんだ!!!
と違うところに八つ当たりしていました。
(´▽`) '`,、'`,、 ちょっと休憩
