powerpoint vba はみ出すテキストの処理 (現状失敗)

なかなか厄介なものに出会って困っています。これも解決へ持っていけるのか，はたまた代替案を持っていくのか。

PowerpointのVBAってスライドショー中にいらないことをさせないって考え方でもあるのかなぁ。( ´ー｀)ﾌｩｰ．．．

ぶつかっている壁は単純だからこそ厄介な感じです。

コードは準備していません。ひとつテキストボックスを加えて，わざとはみ出るようにしています。

編集モードにおいて　イミディエイトウィンドウで下記のコードを実行すると，

activepresentation.Slides(1).Shapes(1).TextFrame2.AutoSize=msoAutoSizeTextToFitShape

想定通りちゃんとテキストに文字がおさまり，

こちらを実行すると，元に戻ります。

activepresentation.Slides(1).Shapes(1).TextFrame2.AutoSize=msoAutoSizeNone

よしよし，コードはこれでよさそうだなぁ・・と，スライドショー中にやると，

msoAutoSizeNoneで解除することはできても， msoAutoSizeTextToFitShapeのほうはガン無視されてしまいます。!?(ﾟ〇ﾟ;)

ここで解除だけうまく働くところも私的には罠としか思えない。両方動かないなら長時間うんうん悩まないで済むのに。。

なかなかこれは厄介で，もうしばらく考えて無理なら　文字数でフォントサイズを変化させるように作るしか無いなぁと逃げを考えています。

なんなんでしょうね。。

あと，いくつもPowerpointのプレゼンファイルを開いたまま操作したりするので，今更ながら， ThisPresentation ってオブジェクトはなんでないんだ!!!

と違うところに八つ当たりしていました。

(´▽`) '`,、'`,、　ちょっと休憩

VBA 有効数字の表示

化学反応式の量的関係のところで，根本的なところからやりなおしています。

ActionSettingのために四角形敷き詰めるなら，そもそも表いらないんじゃ??

というところから(;´▽｀A``

そう思わないといけなくなった理由は，表だとセルの大きさに合わせて文字の大きさを自動調整するような真似ができないからです。

なので，授業で使うレベルまでもっていったんですが，やりなおしているところです。

それと併せて，有効数字の問題。

受験で使うレベルで教えていないので，基本的にはわかりやすさを主眼に放っておけるとこは放っておこうという，曖昧なスタンスでやっていますが，

アボガドロ定数 6.0×10^23が絡む個数についてはいずれにせよ無視できません。

とりあえず間に合わせるためにネットで見つけたコードを利用してやっていたんですが，それじゃあ公開に適さないので，自分で考えてみました。

ぽいのができたので，載せます。

Function 有効数字表示(値 As Single, 桁 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(値, Format_)
    If 指数表示 = True Then
        有効数字表示 = Replace(Val_, "e", "×10^")
    Else
        有効数字表示 = CSng(Left(Val_, InStr(Val_, "e") - 1) & "e" & Mid(Val_, InStr(Val_, "e") + 1))
    End If
End Function

どうでしょう，数学的処理を避けたFormat関数によろしく!なコードです。

個数などは指数表示が適していますが，そうでない部分は指数表示が理解できない子には敷居が高いし，

受験にいらないレベルで話すなら，指数表示を理解するかどうかというのは枝葉だと思います。

なので，そのあたりに対応するように，3つ目の引数をつけた感じです。

この関数に数値を入れてみると，

?有効数字表示(0.2551,3,false)
0.255
?有効数字表示(0.2551,3,true)
2.55×10^-1

?有効数字表示(6e23,3,false)
6E+23
?有効数字表示(6e23,3,true)
6.00×10^23

?有効数字表示(0.2551,2,false)
0.26
?有効数字表示(0.2551,2,true)
2.6×10^-1

?有効数字表示(0.2,2,false)
0.2
?有効数字表示(0.2,2,true)
2.0×10^-1

だいたい私の要件は満たしていますが，大事なものがまだ。

指数表示じゃない時の末尾の０，どうやって付け足そうかなぁ　( ´ー｀)ﾌｩｰ．．．

追記　読みやすさより，試行錯誤を残すスタイルでそのまま付け足します。とりあえず末尾の０を考えてみました。
コードが長くなって嫌いですが仕方なし。。

Function 有効数字表示(値 As Single, 桁 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(値, 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 Len(有効数字表示) = 1 Then 有効数字表示 = 有効数字表示 & "."
                有効数字表示 = 有効数字表示 & String(桁 - 数値桁, "0")
        End If
    End If
End Function

※最後あたりを少し書き直しました(10/28)
もっとすっきり書けないかなぁ(;´▽｀A``

とりあえず結果。

?有効数字表示(6e23,3,false)　　　　
6E+23　　　　　　　←指数表示=falseの場合は想定外な数値なのでスルー

?有効数字表示(0.2,3,false)
0.200

?有効数字表示(0.224,2,false)
0.22
?有効数字表示(0.224,3,false)
0.224
?有効数字表示(0.224,4,false)
0.2240

?有効数字表示(0.0224,2,false)
0.022
?有効数字表示(0.0224,3,false)
0.0224

それっぽい。指数表示でしか無理な場合はfalseの場合はどうでもいいので，その時に対しては無視しています。。

自分で使う分にはこれでいいかな。

Powerpoint VBA 表で遊ぶ その２

表をきちんと制御できるようにしようと思って，目的もなく作ってたら何かにつかえそうだったので載せます。

オセロ作れる・・?挟まれたやつの判別ルーチンができたら作れるかなぁ。

Const 全幅 = 960, 全高 = 540


Sub test()
    Dim Sld1 As Slide: Set Sld1 = ActivePresentation.Slides(1)
    Const 行数 As Long = 11, 列数 As Long = 7
    Dim 行高さ As Long, 列幅 As Long
    行高さ = 全高 / 行数
    列幅 = 全幅 / 列数
    Dim i, j
    With Sld1.Shapes.AddTable(行数, 列数, 0, 0, 全幅, 全高)
        .Name = "表"
        .Fill.ForeColor.RGB = rgbWhite
        With .Table
            .ApplyStyle "{5940675A-B579-460E-94D1-54222C63F5DA}" '"スタイルなし、表のグリッド線あり"
            For i = 0 To 行数 - 1
                For j = 0 To 列数 - 1
                    With Sld1.Shapes.AddLabel(msoTextOrientationHorizontal, j * 列幅, i * 行高さ, 列幅, 行高さ)
                        .Name = i + 1 & " " & j + 1
                        With .ActionSettings(ppMouseClick)
                            .Action = ppActionRunMacro
                            .Run = "編集"
                        End With
                        With .ActionSettings(ppMouseOver)
                            .Action = ppActionRunMacro
                            .Run = "変化"
                        End With
                    End With
                Next
            Next
        End With
    End With
    
End Sub

Sub 編集(Shp As Shape)
    Dim Sld1 As Slide: Set Sld1 = ActivePresentation.Slides(1)
    Dim arr, ret
    arr = Split(Shp.Name)
    ret = InputBox("値を入力")
    Sld1.Shapes("表").Table.Cell(arr(0), arr(1)).Shape.TextFrame.TextRange.Text = ret
End Sub

Sub 変化(Shp As Shape)
    Dim Sld1 As Slide: Set Sld1 = ActivePresentation.Slides(1)
    Sld1.Shapes("表").Fill.ForeColor.RGB = rgbWhite
    Dim arr, ret
    arr = Split(Shp.Name)
    Sld1.Shapes("表").Table.Cell(arr(0), arr(1)).Shape.Fill.ForeColor.RGB = rgbGray
End Sub

testを実行したら表を作ります。その後スライドショーにすると

ちっちゃくてすみません。表の上のセルをカーソルが動くとそこの色を変えるってだけです(;´▽｀A``

とてもとても単純ですが，何かできそうな気がしますね。。

VBA 分子量などを計算してみる

できる範囲で自動化できることは自動化するために，こまごまとしたパーツ作りです。

分子量や式量を求めさせるのを作ってみました。原子量は最低限しかまだ書いていないので，本当に使うときはConstの中身をきちんとしないとですが，

できるかできないか確認しているところです。

コード

Const 原子量 = "H,1,C,12,N,14,O,16,Na,23,Al,27,P,31,Cl,35.5,Ca,40"

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

Sub test()
    Debug.Print "C3H8" & " " & 式量("C3H8")
    Debug.Print "CH3COOH" & " " & 式量("CH3COOH")
End Sub

Regexpの参照設定が必要です。

testを実行すると，

C3H8 44
CH3COOH 60

と返してきます。

動いてそうです。正規表現便利。

vbaであればアプリはなんであれ動くと思うので，Powerpoint用とは言えないかなぁ　( ´ー｀)ﾌｩｰ．．．

わからなかったこと。 Powerpoint VBAでHighlightの解除

今日かなり調べてもわからなかったことがあったので，投稿。誰か知ってる人いらっしゃったら教えてほしいです。

蛍光ペン風に文字を目立たせるには，TextFrame2.TextRange.Font.Highlightで指定ができるのは，把握しています。

私的には便利。とてもいいなぁと思います。

イミディエイトウィンドウでやりました。

activewindow.Selection.ShapeRange(1).TextFrame2.TextRange.Characters(3,2).Font.Highlight.RGB=rgbyellow

でも，使用を断念せざるを得なかった。理由はハイライトをクリアする方法がわからなかったから。

何度も同じ表で繰り返し作業をすることがあるので，クリアできないと困ります。。

どうしたらVBAでクリアできますか・・?(ノД`)・゜・。

追記

いい解決ではないかもですがtext frame.deletetext で文字を消すとhighlight属性も消えてくれる模様。これなら使えそう

Powerpoint VBA 表で遊んでみる。

化学反応式の量的関係，と呼ばれる話が化学基礎にあります。

表で説明していったりするんですが，なかなか理解してもらえない。

値を変化させることで，どのような感じに数値が変化していくのかを見てもらい，理解に結び付く子が増えたらいいなぁと思いながら作りました。

それは載せるのはちょい大変なので，そこで遊んだ表の仕組みの話。

いちいち編集モードに戻らずに表の値を編集したい，というニーズから思いついた単純なものです。

コードはこちら。

Sub 準備()
Dim Sld As Slide: Set Sld = ActivePresentation.Slides(1)
Dim Tbl As Table
With Sld.Shapes.AddTable(4, 3, 50, 50, 300, 200)
    .Name = "表"
    Set Tbl = .Table
End With

Dim i, j
For i = 1 To 4
    For j = 1 To 3
        With Sld.Shapes.AddLabel(msoTextOrientationHorizontal, 100 * j - 50, 50 * i, 100, 50)
            .Name = i & "," & j
            .Line.Visible = msoFalse
            .Fill.Visible = msoFalse
            With .ActionSettings(ppMouseClick)
                .Action = ppActionRunMacro
                .Run = "編集"
            End With
        End With
    Next
Next

End Sub

Sub 編集(Shp As Shape)
    Dim Sld As Slide: Set Sld = ActivePresentation.Slides(1)
    Dim Tbl As Table: Set Tbl = Sld.Shapes("表").Table
    Dim ret As Variant
    ret = InputBox("値を入力")
    Tbl.Cell(Left(Shp.Name, 1), Right(Shp.Name, 1)).Shape.TextFrame.TextRange.Text = ret
End Sub

新規のプレゼンテーションに標準モジュールを追加してそこにペタッと貼れば準備は終わりです。

まず「準備」マクロを実行すると，表を作ります。

見た目には表しかないように見えるはずですが，その表面に透明のラベルを並べています。

名前を右側に表示していますが，マクロを読んでもらえばわかりますが， 行,列　で名前をラベルにつけています。

そのラベルにはマウスクリックで　「編集」　マクロが動くよう設定していて，インプットボックスにより，値を取得し，表の該当部分にその値を書き込む，というマクロです。

とっても単純。

スライドショーにして，マウスで表の一部をクリックしてみてください。インプットボックスが出てきます。これで値を入れれる。

簡素極まりないですが，スライドショーのまま，値を入力できる，というのは実現できているので，

電子黒板で話を完結させることがある私には，今後も使い勝手があるなぁと思っています。

同じ順番で現れる 不特定桁の数値の比較をしてみる。

反応式の奴は落ち着いたんですが，一度できたあとも改善できないか遊んでいたら，記事になりそうでしたので書いてみています。

まずは準備のコード。

Sub 準備()
    Dim TSld As Slide: Set TSld = ActivePresentation.Slides(1)
    With TSld.Shapes.AddLabel(msoTextOrientationHorizontal, 0, 50, 300, 50)
        With .TextFrame
            .AutoSize = ppAutoSizeNone
            With .TextRange
                .Text = "H 4,S 100,Cl 1,Mn 3"
                .Font.Color.RGB = rgbBlack
            End With
        End With
        .Line.ForeColor.RGB = rgbBlack
        .Line.Weight = 2
        .Name = "Label1"
    End With
    
    With TSld.Shapes.AddLabel(msoTextOrientationHorizontal, 0, 200, 300, 50)
        With .TextFrame
            .AutoSize = ppAutoSizeNone
            With .TextRange
                .Text = "H 8,S 9,Cl 5,Mn 3"
                .Font.Color.RGB = rgbBlack
            End With
        End With
        .Line.ForeColor.RGB = rgbBlack
        .Line.Weight = 2
        .Name = "Label2"
    End With
End Sub

これを実行すると，

二つのテキストボックスを挿入し，中に元素記号と数字が並んでいる状態になると思います。
S 100　とかあほな数字を書いていますが，まぁ桁をずらしたかっただけです。

さて，この数字部分だけが等しいかどうかを判別し，異なる場合は色をつける。

こういうことをしようとすると，普通にやるとまぁまぁ面倒になるんじゃないかと思います。

簡単な正規表現を使ってそれを処理したのが次のコード

Sub 照合()
    Dim TSld As Slide: Set TSld = ActivePresentation.Slides(1)
    Dim Lbl1 As TextRange: Set Lbl1 = TSld.Shapes("Label1").TextFrame.TextRange
    Dim Lbl2 As TextRange: Set Lbl2 = TSld.Shapes("Label2").TextFrame.TextRange
    
    'Microsoft VBScript Regular Expression 5.5への参照設定が必要です
    Dim Reg As New RegExp, Mat1 As MatchCollection, Mat2 As MatchCollection
    
    With Reg
        .Global = True
        .Pattern = "[0-9]+"
        Set Mat1 = .Execute(Lbl1.Text)
        Set Mat2 = .Execute(Lbl2.Text)
    End With
    
    Lbl1.Font.Color.RGB = rgbBlack
    Lbl2.Font.Color.RGB = rgbBlack
    Dim i, Arr As Variant
    Arr = Array(rgbRed, rgbBlue, rgbYellow, rgbPink, rgbGreen)
    
    For i = 0 To Mat1.Count - 1
        If Mat1(i) <> Mat2(i) Then
            Lbl1.Characters(Mat1(i).FirstIndex + 1, Mat1(i).Length).Font.Color.RGB = Arr(i)
            Lbl2.Characters(Mat2(i).FirstIndex + 1, Mat2(i).Length).Font.Color.RGB = Arr(i)
        End If
    Next

End Sub

いつも通り，RegExpを使うために参照設定が必要です。コメントで書いてます。実行速度にも影響がありますし，わたしは事前バインディングしか使わない派です。

正規表現のバターンは非常に簡単。　0-9　の数字が一回以上あるのを捕まえる，というように書いています。
照合　マクロを実行すると，

このようになります。
それぞれの文字列に対し，正規表現を適用し，マッチコレクションをMat1,Mat2放り込んでいます。

こんな感じで格納されているので，比較して，違ったらFirstIndexとLengthを使って指定し，色を変えています。

私がやる操作って，こういう類のものが多い気がするので，今後も使っていけそうな感じでした。