- ホーム
- Other
- キー操作を記録し、同期してBeep音をON/OFFする
キー操作をリアルタイムにCSVに記録し、併せてキーを押している間はBeep音を出す
キー操作のログ（押した、離した時刻）をリアルタイムでCSVファイルに記録します。
また、キーを押している間はBeep音を出します。
QAサイトで回答したものの使い途がよく分かりませんが、Beep音のWaveファイル生成にまで手を出してみました。
MIDを左辺に置く文字列操作を覚えたので使ってみましたが、どうせ最後に書き込むなら配列に収納していく方が速いかもしれません。
☆ここはおまけ
単一周波数（正弦波）のWaveファイルを生成します
'コードの出典
'http://www.gizcollabo.jp/vbtomo/boards/vbhajikari_spread_3403.html
'正弦波のデータ生成部のみアレンジさせていただいております。
' ofs Data
' +0 "RIFF":=&h46464952&
' +4 <続くデータのバイト数>
' +8 "WAVE":=&h45564157&
' +12 "fmt ":=&h20746d66&
' +16 Len(WAVEFORMAT_my):=16
' +20 <WAVEFORMAT_myの実体>
' +36 "data":=&h61746164&
' +40 <波形データのバイト数>
' +44 <波形データ>
Private Const WAVE_FORMAT_PCM = 1
Private Const hdr_RIFF As Long = &H46464952
Private Const hdr_WAVE As Long = &H45564157
Private Const hdr_fmt As Long = &H20746D66
Private Const hdr_data As Long = &H61746164
Private Const WAVEFORMAT_myLen As Long = 16
Private Type WAVEFORMAT_my
wFormatTag As Integer 'WAVE_FORMAT_PCMを利用
nChannels As Integer 'MONO Channelにする
nSamplesPerSec As Long 'Sample rate, in samples per second.
nAvgBytesPerSec As Long 'For example, 16-bit stereo at 44.1 kHz has an average data rate of 176,400 bytes per second
'=<量子化数/8*サンプリングレート*チャンネル数>?
nBlockAlign As Integer 'For example, the block alignment for 16-bit stereo PCM is 4 bytes
'=<量子化数/8*チャンネル数>?
wBitsPerSample As Integer '量子化数
End Type
'メインルーチン
Sub test0()
makeWave 659.255114, ThisWorkbook.Path & "\" & "sample.wav", 5
End Sub
'freq Waveファイルを作成する単音の周波数Hz
'filePath出力するWaveのファイルフルパス（拡張子 .wavもつける事）
'SamSecLen 出力する音の長さ(sec)
Private Sub makeWave(freq As Double, filePath As String, Optional SamSecLen As Double)
Const Gain As Long = 30000 'ほぼ最大のゲイン
Const pi = 3.1415926
Dim i As Long '一般変数
Dim ff As Integer 'ファイルナンバー用
' Dim SamSecLen As Double 'サンプル時間(秒)
Dim wf As WAVEFORMAT_my 'WAVEFORMAT_myの実体
Dim sintable(0 To 359) As Integer 'サインテーブル
Dim WaveDataLen As Long '波形データ長
Dim WaveData() As Integer '実波形データ
Dim dataArray() As Variant
With wf
.wBitsPerSample = 16
.wFormatTag = WAVE_FORMAT_PCM
.nChannels = 1
.nSamplesPerSec = 44.1 * 1000 '44.1kHz
.nAvgBytesPerSec = .wBitsPerSample / 8 * .nSamplesPerSec * .nChannels
.nBlockAlign = .wBitsPerSample / 8 * .nChannels
End With
'サンプル時間の初期値
If IsMissing(SamSecLen) Then
SamSecLen = 1
End If
'サンプル時間を収められるWaveDataを作る
WaveDataLen = wf.nSamplesPerSec * SamSecLen
ReDim WaveData(1 To WaveDataLen)
'WaveDataを決定する
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
For i = 1 To WaveDataLen
WaveData(i) = Gain * Sin(2 * pi * freq * (1 / wf.nSamplesPerSec) * i)
Next i
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
'データをファイルに書き込む
ff = FreeFile
Open filePath For Binary As ff
Put #ff, 1, hdr_RIFF ' +0 "RIFF":=&h46464952&
Put #ff, , 0& ' +4 <続くデータのバイト数>
Put #ff, , hdr_WAVE ' +8 "WAVE":=&h45564157&
Put #ff, , hdr_fmt ' +12 "fmt ":=&h20746d66&
Put #ff, , WAVEFORMAT_myLen ' +16 Len(WAVEFORMAT_my):=16
Put #ff, , wf ' +20 <WAVEFORMAT_myの実体>
Put #ff, , hdr_data ' +36 "data":=&h61746164&
Put #ff, , WaveDataLen * 2 ' +40 <波形データのバイト数>
Put #ff, , WaveData ' +44 <波形データ>
'最後に +4 の<続くデータのバイト数>を書き込む
Put #ff, 1 + 4, Seek(ff) - 4 - 1
Close ff
End Sub
☆標準モジュール
'空のUserFormを表示し、スペースキーの操作に同期してBeep音を奏で、キー操作を記録します。フォームを閉じるときCSVに保存します。
Sub test()
UserForm1.Show
End Sub
☆クラスモジュール
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
☆UserForm1モジュール
Private WithEvents keyCheck As keyCheckClass
Private Declare Function GetTickCount Lib "kernel32" () As Long
Private 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
Private Const SND_ASYNC = &H1
Private Const SND_MEMORY = &H4
Private Const SND_LOOP = &H8
Dim BufSndTest() As Byte
Dim buf As String * 50000 '2^16文字が最大か
Dim pos As Long
Private Sub keyCheck_keyPushed(ByVal upEdge As Boolean)
If upEdge Then
startSound
Mid(buf, pos, 13) = "1,&H" & Right("0000000" & Hex(GetTickCount), 7) & vbCrLf
pos = pos + 13
Else
StopSound
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 keyCheckClass
pos = 1
End Sub
Private Sub UserForm_Activate()
ReadSoundBuffer
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
Private Function ReadSoundBuffer()
Dim WrkSndFile As String
Dim WrkNumber As Long
WrkSndFile = ThisWorkbook.Path & "\sample.wav"
WrkNumber = FreeFile()
Open WrkSndFile For Binary As WrkNumber
ReDim BufSndTest(LOF(WrkNumber))
Get WrkNumber, , BufSndTest
Close WrkNumber
End Function
Private Sub startSound()
PlaySound BufSndTest(0), 0, SND_ASYNC + SND_MEMORY + SND_LOOP
End Sub
Private Sub StopSound()
Call PlaySound2(vbNullString, 0, 0)
End Sub