エクセルVBAで音を出すには

質問

エクセルマクロの質問です。キーを押している間、音（ビープ音）がなってその時間も同時に測定できますか？

スペースキーを押している間、音（ビープ音）がなってその時間も同時に測定したいと考えています。
音楽キーボードのように音の発音に遅延がなくこのようなことはできるでしょうか？
また、
キー押す（楽譜で言えば音符の音価）
キー離す（休符の音価）
をそれぞれミリ秒単位で同時に記録し、ｃｓｖ形式で保存させたいです。

ご回答の内容で分からないことがあれば、自分で再検索するなどしてがんばりますので、
できるだけシンプルな方法を教えてください。

よろしくお願いいたします。

回答No.4

mitarashi · ベストアンサー

#1～です。しつこくてすみません。
#3についてですが、
Public Sub startSound()
Call ReadSoundBuffer
PlaySound BufSndTest(0), 0, SND_ASYNC + SND_MEMORY + SND_LOOP
End Sub
の、Call ReadSoundBufferは実際には、UserForm1_Initializeあたりで実行して下さい。#3のままでは毎回ファイルから読み込むので意味がありません。
なお、PlaySoundを一つの宣言で済まそうと、Byte型の変数や配列に0を収納して渡してみたりしましたが、うまくいきませんでした。ギブアップ状態です。
以上。

お礼

本当にありがとうございました。
実際にはまだコードを動かしていないのですが、
ここから先は自力で改良していきます。

自分もmitarashiさんのように人の役に立てるように
スキルアップしたい！と思いました。
ありがとうございました。

回答No.3

mitarashi

#2の補足・修正です。
遅延防止の観点から、Waveファイルを読み込むのはまずかろうと検索してみると、事前にメモリに読み込んで置く方法がみつかりました。
http://home.att.ne.jp/zeta/gen/excel/c04p04.htm
これを用いて、サウンドスタート、ストップの所を作成というか切り貼りしてみました。
なお、上記URLの記述と異なり、PlaySound( 0, 0, 0 )を実行しても止まらないので、同じAPIを二種類のやりかたで宣言するというお馬鹿な事をしています。

Public Declare Function PlaySound Lib "winmm.dll" Alias "PlaySoundA" ( _
ByRef pszSound As Byte, _
ByVal hmod As Long, _
ByVal fdwSound As Long _
) As Long
'PlaySound(0,0,0)では止まらないので苦肉の策
Private Declare Function PlaySound2 Lib "winmm.dll" Alias "PlaySoundA" _
(ByVal pszSound As String, ByVal hmod As Long, ByVal fdwSound As Long) As Long
Public Const SND_ASYNC = &H1
Public Const SND_MEMORY = &H4
Private Const SND_LOOP = &H8

Public BufSndTest() As Byte

Public Function ReadSoundBuffer()
’略
'丸ごと転載は著作権法上心配なので、上記URLをご覧下さい。
End Function

Public Sub startSound()
Call ReadSoundBuffer
PlaySound BufSndTest(0), 0, SND_ASYNC + SND_MEMORY + SND_LOOP
End Sub

Private Sub StopSound()
Call PlaySound2(vbNullString, 0, 0)
End Sub

なお、#2で回答しているAcStartSound,AcStopSoundはActiveXコントロール操作部を削って改造しておりましたので、補足させていただきます。

回答No.2

mitarashi

#1です。他で行った回答でひらめいたので、遊んでおりました。あまり検証してありませんが、閉じられない内に披露しておきます。
下記ファイル形式で、Windows起動からのミリ秒をCSVファイルに記録します。
ON-OFFの間隔を計算させると時間を食うと思い、CSVを読みこんでから関数なりで処理する考えです。
1,&H0982D8A
0,&H0982DDA
1,&H0983567
0,&H098372A

UserForm1は空っぽでOKです。最初ワークシートで試しましたが、編集に入ってしまいうまくないので、切り替えました。
UserForm1を閉じるときに、動作を終了してまとめてファイルに書き出します。（途中の遅延を避けるためです）
結果として遅延の程を評価する術はありませんが、ご参考まで。

☆標準モジュール
Sub test()
UserForm1.Show
End Sub
他に、'http://www.feedsoft.net/access/tips/tips57.htmlのコードを標準モジュールにコピーして、AcPlaySound,AcStopSoundをPublicに変更しておきます
また、Waveファイルは適当なモノの見繕って下さい。この方面にお詳しいなら、ご自分で作られた方が良いかも。

☆UserForm1モジュール
Private WithEvents keyCheck As Class2
Private Declare Function GetTickCount Lib "kernel32" () As Long

Dim buf As String * 50000 '2^16文字が最大か
Dim pos As Long

Private Sub keyCheck_keyPushed(ByVal upEdge As Boolean)
If upEdge Then
AcPlaySound
Mid(buf, pos, 13) = "1,&H" & Right("0000000" & Hex(GetTickCount), 7) & vbCrLf
pos = pos + 13
Else
AcStopSound
Mid(buf, pos, 13) = "0,&H" & Right("0000000" & Hex(GetTickCount), 7) & vbCrLf
pos = pos + 13
End If
End Sub

Private Sub UserForm_Initialize()
Set keyCheck = New Class2
pos = 1
End Sub

Private Sub UserForm_Activate()
keyCheck.start
End Sub

Private Sub UserForm_Terminate()
Dim buf2 As String
Dim FSO As Object

On Error GoTo errHandler
keyCheck.stopFlag = True
Set keyCheck = Nothing
buf2 = Left(buf, pos - 3) '最後のvbCrLfも削除
'最後にまとめてファイルに書き出す
Set FSO = CreateObject("Scripting.FileSystemObject")
With FSO.CreateTextFile(ThisWorkbook.Path & "\Sample.csv")
.Write buf2
.Close
End With
Set FSO = Nothing
errHandler:
If Err.Number <> 0 Then MsgBox Err.Number & ":" & Err.Description
End Sub

☆Class2モジュール Class1は他で使っていたもので．．．
Public Event keyPushed(ByVal upEdge As Boolean)

Private Declare Function GetAsyncKeyState Lib "User32.dll" ( ByVal vKey As Long ) As Long
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Private Const VK_SPACE = &H20 '[Space]
Private myStopFlag As Boolean

Public Property Let stopFlag(newStopFlag As Boolean)
If newStopFlag Then myStopFlag = True
End Property

Public Sub start()
Dim MyKeyState As Long
Dim previousState As Long
Dim testFlag As Long
Do
MyKeyState = GetAsyncKeyState(VK_SPACE)
If MyKeyState <> &H0 And previousState = &H0 Then
RaiseEvent keyPushed(True)
Else
If MyKeyState = &H0 And previousState <> &H0 Then
RaiseEvent keyPushed(False)
Else
testFlag = 0
End If
End If
previousState = MyKeyState
' Call Sleep(10)
DoEvents
Loop Until myStopFlag
End Sub

回答No.1

mitarashi

ひとしきり検索してみましたが、vbaのBeepでは規定の時間しか鳴らないし、Windows APIのBeepは指定した時間しか鳴らないという事で、APIのPlaySoundで、適当なWaveファイルを連続的に鳴らしてやって制御する方法しか見つかりませんでした。
PlaySound APIで、Windows備え付けのWaveを鳴らす事例は、下記がご参考になります。
http://www.feedsoft.net/access/tips/tips57.html
Option Compare Databaseをコメントアウトすれば、エクセルでも使えます。

簡単にOnKeyでやってみました。Excel2010、WindowsXP SP3環境です。
OnKeyイベントは下記で設定・解除します。
Sub auto_open()
Application.OnKey " ", "myPlaySound"
End Sub

Sub auto_close()
Application.OnKey " ", ""
End Sub

参考URLのコードを少し改造させていただいて、下記を追加すると、とりあえずスペースキーでBeepぽい音のON/OFFが出来ます。（VBEで実行しても何も起こりませんのでご留意下さい）
Dim playingNowFlag As Boolean

Sub myPlaySound()
Dim fname As String
Dim mode As Long

If playingNowFlag Then
Call PlaySound(vbNullString, 0, 0)
playingNowFlag = False
Else
playingNowFlag = True
DoEvents
'Beep代わりになりそうなものを探してみました。
fname = "C:\WINDOWS\Media\ringout.wav"
mode = SND_ASYNC Or SND_LOOP
Call PlaySound(fname, 0, mode)
End If
End Sub

お望みのようなもっと高尚なキー制御をするには、下記がご参考になるかもしれません。
http://home.att.ne.jp/zeta/gen/excel/c04p07.htm
なお、時間の計測は簡単には、GetTickCount APIが使えます。より精度の高いAPIも検索すると複数みつかると思います。

お礼

すごく参考になりました。
ゲーム関係のテクニックを応用するのが
一番、イメージに近いということがわかりました。
また、ＡＰＩについて勉強します。
ありがとうございました。