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

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

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

標準モジュール

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

図形の名前

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

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

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

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

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

If slpChange = True Then trgTxt = trgTxt

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

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

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