読者です 読者をやめる 読者になる 読者になる

Powerpoint VBAを使おう!

Powerpoint VBAやExcelのVBAで遊んでいます。Word VBAも始めました。

無限ループとボタンでつきあう

プログラムを作るときに絶対避けるべきこととして,無限ループがあるとわたしは認識していました。

よくやらかして,強制終了の憂き目にあうこともありますが,パワーポイントで遊んでいる中ではそれなりに無限ループと付き合ってます。

f:id:chemiphys:20161231122210p:plain

標準モジュール

Option Explicit
Declare Sub Sleep Lib "kernel32" (ByVal dwmiliseconds As Long)
Dim flgStop As Boolean
Dim slpChange As Boolean

Sub スタート()
    Dim TSlide As Slide: Set TSlide = ActivePresentation.Slides(1)
    Dim TShp As Shape: Set TShp = TSlide.Shapes("Target")
    Dim trgTxt As TextRange: Set trgTxt = TSlide.Shapes("txt").TextFrame.TextRange

    TShp.Height = 50: TShp.Width = 50
    Dim flg As Long: flg = 1
    
    flgStop = False
    Do
    
        TShp.Height = TShp.Height + 10 * flg
        TShp.Left = TShp.Left - 5 * flg
        TShp.Width = TShp.Width + 10 * flg
        TShp.Top = TShp.Top - 5 * flg
        
        If TShp.Height > 100 Then flg = -1
        If TShp.Height < 50 Then flg = 1
        
        If slpChange = True Then trgTxt = trgTxt
        
        DoEvents
        
        If flgStop = True Then Exit Do
        
        Sleep trgTxt
        
    Loop
End Sub

Sub ストップ()
    flgStop = True
End Sub

Sub 移動(図形 As Shape)
    Dim TSlide As Slide: Set TSlide = ActivePresentation.Slides(1)
    Dim TShp As Shape: Set TShp = TSlide.Shapes("Target")
    
    Select Case 図形.Name
        Case "上"
            TShp.Top = TShp.Top - 20
        Case "下"
            TShp.Top = TShp.Top + 20
        Case "左"
            TShp.Left = TShp.Left - 20
        Case "右"
            TShp.Left = TShp.Left + 20
    End Select
End Sub

Sub スリープ更新ONOFF()
    Dim TSlide As Slide: Set TSlide = ActivePresentation.Slides(1)
    Dim shpTxt As Shape: Set shpTxt = TSlide.Shapes("txt")
    
    If slpChange = True Then
        slpChange = False
        shpTxt.Fill.ForeColor.RGB = RGB(255, 255, 0)
    Else
        slpChange = True
        shpTxt.Fill.ForeColor.RGB = RGB(0, 255, 255)
    End If
End Sub

Sub Sleep変更(図形 As Shape)
    Dim TSlide As Slide: Set TSlide = ActivePresentation.Slides(1)
    Dim trgTxt As TextRange: Set trgTxt = TSlide.Shapes("txt").TextFrame.TextRange

    If Left(図形.Name, 1) = "-" Then trgTxt = trgTxt - 5 Else trgTxt = trgTxt + 5
    If trgTxt < 0 Then trgTxt = 0
End Sub

図形の名前
f:id:chemiphys:20161231124223p:plain


図形にひもづけるマクロ実行
 -Slp , +Slp   には Sleep更新
 Sleep更新    には スリープ更新ONOFF
 Start      には スタート
 上 下 左 右  には 移動
 Stop       には ストップ

ファイル添付できれば楽なんだけど・・無理なんですね。。


スタートボタンを押すと,黄色い丸(Tartget)が大きくなったり小さくなったりを繰り返します。
Do Loopは部分は無限ループにしていますのでずーっとそれを繰り返します。flgStopにより
抜けるようにしてありますが,それをどうするのかがこの記事の肝になります。


DoEventsをループごとに1回入れているので,ループ中ですが,他の働きかけも聞き入れます。
上下左右ボタンを押すと,図形のTop,Leftプロパティにはたらきかけて,動かしてくれます。
四つのボタンに同じ 『移動』というマクロを割り当てていますが,
Nameプロパティにより違う動作をします。


最初 黄色い丸(Target)の動きがぎこちない場合があると思います。
環境に依存するので,一概には言えませんが,高速なPCほどぎこちなくなるかも。
わたしが苦労した コマが飛ぶ現象です。
動きがぎこちなければ,Sleep更新というボタンを押してください。
押すと,たぶんぎこちない動きが解消されます。

If slpChange = True Then trgTxt = trgTxt

という一見意味不明な部分がそれにあたります。
テキストの更新が一つ入るだけで,図形の画面更新がきちんと反映されるようになります。


ストップボタンを押してもらえば,flgStopに気づいて ループから抜けるようになってます。
↑あっさりですが,この記事の肝の部分です。

気づいてしまえばなんということはない仕組みですが,
これでけっこう自由にいろんなことができるようになったので,重宝している作り方です。