理科ならではのPowerpoint VBA - インストールレスプログラミング( ´ー`)

ちょっとExcelのことが増えたので，なかなか増えないパワーポイントVBAを載せるって方面に少し戻します。

多肢選択のクイズを作ったときに作ったしくみです。

どうしても，化学反応式などを扱うと，上付き下付きがちゃんと生きないともやっとします。

でも意外とめんどくさい。PasteSpecialのほうで書式込みでコピーとかもなんとかできたんですが，

いくつも言葉を結合していくと，それもなかなか難しかった。

間違った問題を列挙したくなったりしますから。。(;´▽｀A``

また，すべての工程をその場でやってたら，CPUが比較的貧弱なタブレットパソコン等では動作が気になるレベルまで遅くなったりします。

問題取り込みの時はすこし待てるけど，問題取り組んでるときはすばやくやりたい。

そんなことを考えながら作ったのが次のコードでした。

Excelの元データから吸い上げて，パワーポイントの表にテキストとして貯め，問題表示時などに上付き等を復元するというしくみを

このエントリ用にコンパクトに書き直してみました。
f:id:chemiphys:20170105214939p:plain

『一度テキストのみに戻して次に上付き下付きを復元』を実行すると

f:id:chemiphys:20170105215419p:plain

Split関数に目覚めたコードでした。

Option Explicit

Sub 一度テキストのみに戻して次に上付き下付きを復元()
    Dim TSlide As Slide: Set TSlide = ActivePresentation.Slides(1)
    Dim SBox As TextRange: Set SBox = TSlide.Shapes("SourceBox").TextFrame.TextRange
    Dim TTxt As TextRange: Set TTxt = TSlide.Shapes("TempText").TextFrame.TextRange
    Dim PBox As TextRange: Set PBox = TSlide.Shapes("PasteBox").TextFrame.TextRange
    
    Dim strSuper As String: strSuper = ""
    Dim strSub As String: strSub = ""
    Dim k As Long, j As Long
    
    'テキスト化
    For k = 1 To Len(SBox)
        If SBox.Characters(k, 1).Font.Superscript = True Then strSuper = strSuper & "," & k
        If SBox.Characters(k, 1).Font.Subscript = True Then strSub = strSub & "," & k
    Next
    'TempBoxに一度入れる
     TTxt = SBox & "■" & Mid(strSuper, 2) & "■" & Mid(strSub, 2)
    
    '上付き下付きを復活
    Call SubAndSuperScript(PBox, TTxt.Text, 0)
End Sub

Sub SubAndSuperScript(TxRange As TextRange, St As String, Hosei As Byte)
    Dim i As Byte
    
    TxRange.Text = Split(St, "■")(0)
    If Split(St, "■")(1) <> "" Then
        For i = 0 To UBound(Split(Split(St, "■")(1), ","))
            TxRange.Characters(Split(Split(St, "■")(1), ",")(i) + Hosei, 1).Font.Superscript = msoTrue
        Next
    End If
    If Split(St, "■")(2) <> "" Then
        For i = 0 To UBound(Split(Split(St, "■")(2), ","))
            TxRange.Characters(Split(Split(St, "■")(2), ",")(i) + Hosei, 1).Font.Subscript = msoTrue
        Next
    End If
End Sub