珍現象、解決（？）す

VBA一般

ち～んｗ珍現象、解決す

ご心配をおかけしました。

前回

akashi-keirin.hatenablog.com

のち～んｗ珍現象がなぜか解決いたしましたので、ご報告申し上げまする。ニンニン。

あまりにしょうもない顛末なので、怒らないように。

これまでの対処法

カウントダウンさせるcountDownメソッドの概略は、当初次のようなものだった。

リスト１
Public Sub countDown( _
    Optional ByVal milliSecPerSec As Long = 1000)

  カウントダウン表示をする処理

End Sub

当り前だ。

で、次に、wavを再生するplaySoundメソッドを作成し、カウントダウン終了時にだけ鳴らせばよいわけだから、次のようにcountDownメソッドの末尾に追加した。

リスト２
Public Sub countDown( _
    Optional ByVal milliSecPerSec As Long = 1000)

  カウントダウン表示をする処理
  Call playSound

End Sub

カウントダウン表示が完了してからplaySoundメソッドを呼んでいるのだから、これで完璧のはずだった。しかし、実際は、〈表示が「あと0分01秒」となっているのに派手に音が鳴る〉という実にマヌケなことになっていたのだ。

なんでやねん。

私は焦った。

そこで、次のようにしてみた。

リスト３
Public Sub countDown( _
    Optional ByVal milliSecPerSec As Long = 1000)

  カウントダウン表示をする処理
  DoEvents
  Call playSound

End Sub

見ての通り、カウントダウン処理の後、playSoundメソッドを呼ぶ前にDoEventsをかましてみた。

それでもだめだった。

私はもっと焦った。

さらに次のようにしてみた。

リスト４
Public Sub countDown( _
    Optional ByVal milliSecPerSec As Long = 1000)

  カウントダウン表示をする処理
  DoEvents
  WindowsAPI関数でWaitする処理
  Call playSound

End Sub

カウントダウン表示処理終了後にWaitを入れてみたのである。

しかしこれでもダメだった。

私は途方に暮れた。

しかし、希望を捨てなかった。

ついにplaySoundメソッドをPublicにして、呼び出し側を次のようにしてみた。

リスト５
Private Sub entry()

  KitchenTimerクラスのインスタンスを用意する処理

  Call kitTimer.countDown(引数)
  Call kitTimer.playCount

End Sub

countDownメソッドとplaySoundメソッドを二段階に分けて呼び出すのだ。

まさに盤石の布陣。諸葛孔明の八卦の陣とて、この布陣には敵うまいて、ふふふ……。

結果は、やっぱりダメｗ

ついに万策尽き果てたのだった……。

なぜか治る

処理の節目節目にDebug.Printを入れ、改めてplaySoundメソッドの前後に長めのWaitを入れてゴニョゴニョしていると、突然治った。

f:id:akashi_keirin:20190923155353g:plain

※音が鳴らないと何のことかわからないので、playSoundメソッドの開始時にＡ２セルに「演奏中」、終了時に「演奏おわり」と書き込む処理を加えています。

ほら。

で、一度この状態になると、

  • playSoundメソッドの冒頭にDoEventsを入れる
  • countDownメソッド内でplaySoundメソッド呼び出し前に1ミリ秒のWaitを入れる

など、とにかくどこかでDoEventsかWaitを入れるようにすれば、ちゃんとカウントダウン終了後に音を鳴らしてくれるようになった。

おわりに

うーむ……、何だったんだろう……。

とりあえず、現時点でのKitchenTimerクラスのコードを載っけておく。

クラスモジュール KitchenTimer
Option Explicit

'Win32API Declaration'
'For Calc Time'
Private Declare Function GetTickCount Lib "kernel32" () As Long
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

'For Play Sound'
Private Declare Function mciSendString _
                  Lib "winmm.dll" _
                  Alias "mciSendStringA" ( _
                           ByVal lpstrCommand As String, _
                           ByVal lpstrReturnString As String, _
                           ByVal uReturnLength As Long, _
                           ByVal hwndCallback As Long) As Long

'Constants'
Private Enum TimerStatus
  tsRemaining
  tsPaused
  tsFinished
End Enum

'Module Level Variables'
Private fsObj As New FileSystemObject

'Module Level Variables; Fields'
Private minutes As Long
Private seconds As Long
Private soundSrcPath_ As String
Private totalSeconds As Long
Private status_ As TimerStatus

Private minDisp As Range
Private secDisp As Range
Private statDisp As Range

Private isInitialized As Boolean

Private isPaused As Boolean

Private Sub Class_Initialize()
  totalSeconds = 0
  isPaused = True
  isInitialized = False
End Sub

'Properties'
Private Property Get Status() As String
  Dim ret As String
  Select Case status_
    Case tsRemaining: ret = "あと"
    Case tsPaused: ret = "一時停止"
    Case tsFinished: ret = "終了！"
  End Select
  Status = ret
End Property

Public Property Get HasDone() As Boolean
  HasDone = True
  If status_ = tsFinished Then Exit Property
  HasDone = False
End Property

'Methods'
Public Sub init(ByVal minDisplay As Range, _
                ByVal secDisplay As Range, _
                ByVal statDisplay As Range, _
       Optional ByVal soundSrcPath As String)
  Set minDisp = minDisplay
  Set secDisp = secDisplay
  Set statDisp = statDisplay
  If soundSrcPath <> "" Then
    If Not fsObj.FileExists(soundSrcPath) Or _
       StrConv(Right(soundSrcPath, 4), vbLowerCase) <> ".wav" Then _
      soundSrcPath = ""
  End If
  soundSrcPath_ = soundSrcPath
  isInitialized = True
End Sub

Public Sub countDown( _
    Optional ByVal milliSecPerSec As Long = 1000)
  If Not isInitialized Then Exit Sub
  isPaused = False
  minutes = minDisp.Value
  If minutes < 0 Then minutes = 0
  seconds = secDisp.Value
  If seconds < 0 Then seconds = 0
  If seconds > 59 Then seconds = 0
  totalSeconds = minutes * 60 + seconds
  If minutes + seconds = 0 Then Exit Sub
  Dim interval As Long
  interval = milliSecPerSec - 1
  status_ = tsRemaining
  statDisp.Value = Status
  Do While totalSeconds > 0
    If isPaused Then _
      status_ = tsPaused: statDisp.Value = Status: _
      Exit Do
    Call waitFor(interval)
    totalSeconds = totalSeconds - 1
    minutes = totalSeconds \ 60
    minDisp.Value = minutes
    seconds = totalSeconds Mod 60
    secDisp.Value = seconds
  Loop
  If totalSeconds > 0 Then status_ = tsPaused
  If totalSeconds = 0 Then
    status_ = tsFinished
    statDisp.Value = Status
    Call playSound
  End If
End Sub

Public Sub pause()
  isPaused = Not isPaused
End Sub

Public Sub reset()
  isPaused = True
  totalSeconds = 0
  minutes = 0
  minDisp.Value = minutes
  seconds = 0
  secDisp.Value = seconds
  status_ = tsFinished: statDisp.Value = Status
End Sub

'Internal Methods'
Private Function callGetTickCount() As Long
  Dim ret As Variant
  ret = GetTickCount()
  ret = CDec(ret)
  If ret < 0 Then ret = ret + 2 ^ 32
  callGetTickCount = ret
End Function

Private Sub callSleep(ByVal milliSeconds As Long)
  Call Sleep(milliSeconds)
End Sub

Private Sub waitFor(ByVal milliSeconds As Long)
  Dim startTime As Long
  startTime = callGetTickCount()
  Dim endTime As Long
  Do
    Call Sleep(1)
    DoEvents
    endTime = callGetTickCount()
  Loop Until endTime - startTime > milliSeconds
End Sub

Private Sub playSound()
  If soundSrcPath_ = "" Then Exit Sub
  DoEvents
  Dim rc As Long
  soundSrcPath_ = """" & soundSrcPath_ & """"
  rc = mciSendString("Open " & soundSrcPath_, "", 0, 0)
  rc = mciSendString("Play " & soundSrcPath_ & " wait", "", 0, 0)
  rc = mciSendString("Close " & soundSrcPath_, "", 0, 0)
  status_ = tsPaused
End Sub