VBAでwavを鳴らしたら珍現象が起きた話
VBAでwavを鳴らしたらち～んｗ珍現象が起きた
解決方法を知っている人がいたら、教えろ教えてください。
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
'Constructor'
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
'Methods'
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
DoEvents
If totalSeconds > 0 Then status_ = tsPaused
If totalSeconds = 0 Then
status_ = tsFinished
statDisp.Value = Status
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
Public Sub playSound()
If soundSrcPath_ = "" Then Exit Sub
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
※上掲コードはご覧のとおり32bit版Officeのものです。64bit版をご利用の方は、しかるべく修正してお使いください。
まあ、64ビット対応っつってもこの場合だったらPtrSafe入れるだけでいいと思うけど。
擬似コンストラクタinitメソッドの冒頭を
Public Sub init(ByVal minDisplay As Range, _
ByVal secDisplay As Range, _
ByVal statDisplay As Range, _
Optional ByVal soundSrcPath As String)
このようにしている。
引数が計四つ。
第１引数minDisplayには、「分」数を表示させるセルを指定。第２引数secDisplayには、「秒」数を表示するセルを指定。第３引数statDisplayには、カウントダウンの状態を表示するセルを指定。あと、省略可能の第４引数soundSrcPathには、カウントダウン終了後に鳴らすwavファイルのフルパスを指定することにしている。
外部に公開するメソッドは「countDown」、「pause」、「reset」の三つ。
何をするメソッドなのかは、名前を見たらわかるだろう。まさにキッチンタイマーを操作するときのアレとかアレである。
使ってみる
たとえば、ワークシート上に
このようにキッチンタイマー風の外観を作成しておき、次のようなコードで利用する。
リスト１
Private Sub testKitchenTimer()
Dim kitTimer As KitchenTimer '……(1)'
Set kitTimer = New KitchenTimer
Call kitTimer.init(minDisplay:=Sh01Main.Range("B2"), _
secDisplay:=Sh01Main.Range("D2"), _
statDisplay:=Sh01Main.Range("A1"), _
soundSrcPath:=ThisWorkbook.Path & _
"\SoundSrc\GOLDEN AXE Voice Yell.wav")
Call kitTimer.countDown(Sh01Main.Range("G1").Value) '……(2)'
Call kitTimer.playSound '……(3)'
End Sub
(1)の
Dim kitTimer As KitchenTimer
Set kitTimer = New KitchenTimer
Call kitTimer.init(minDisplay:=Sh01Main.Range("B2"), _
secDisplay:=Sh01Main.Range("D2"), _
statDisplay:=Sh01Main.Range("A1"), _
soundSrcPath:=ThisWorkbook.Path & _
"\SoundSrc\GOLDEN AXE Voice Yell.wav")
でインスタンス生成。引数祭りで申しわけないが、
- 「分」数表示セルはＢ２セル
- 「秒」数表示セルはＤ２セル
- 状態を表示するセルはＡ１セル
- カウントダウン終了時に鳴らすwavファイルは、このプロジェクトのあるフォルダの中の「
SoundSrc」フォルダ内の「GOLDEN AXE Voice Yell.wav」
とまあ、こんな感じの設定。
画面は
こんなの。
Ｇ１セルの「333」というのは、カウントダウンの1秒を何ミリ秒にするか、という数値。
倍速でカウントダウンさせたければ、「500」にすれば良い。
目分量だが、「850」ぐらいまでならバレないｗ
画面では「333」にしているので、約３倍速。
(2)の
Call kitTimer.countDown(Sh01Main.Range("G1").Value)
のように、countDownメソッドの引数として渡してやる。
カウントダウンが終わったら、(3)の
Call kitTimer.playSound
でwavを再生して終わり。
ちなみに、画面ではコマンドボタンを置いているが、今回はcountDownとplaySoundメソッドしか使わないので、ボタンの存在は無視してください。
ち～んｗ珍現象
上記リスト１を実行すると、カウントダウン終了→wavファイル鳴動、となる……はずである。ところが、
音が鳴らないのでわかりにくいかも知れないが、「あと0分01秒」で止まっているのがわかるだろうか。
止まっている間にwavが鳴っているのである。
コードの実行順から考えると、表示が「0分00秒」になる→wavが鳴る、の順にならねばならんはずなのに。
おわりに
ちなみに、リスト１の(3)の行にブレークポイントを置いて実行すると、ちゃんと「0分00秒」になってから止まる。
なのに、通し実行すると「0分01秒」のところで一旦音が鳴り、鳴り終わってから「0分00秒」になるのである。
何ででしょう？？？
誰かわかる人いたら教えろ教えてください。
