| |
マルチバッファリングを利用して音を途切れさせずに再生させるためVBAでWin32APIのwaveOut関数を利用したいです。モジュールに下記のように書いてみたのですがエラーも出ないまま落ちてしまいます。どのように改善すればいいでしょうか。
＜参考にしたサイト＞
ht tp://www13.plala.or.jp/kymats/study/MULTIMEDIA/waveOut_create.html
ht tp://www.chujno.com/admon/ctools/vbapi/apidetail.asp?api_id=531
＜動作＞バイト配列上の一秒間のサイン波を再生します
＜注意＞下記のコードを実行するとExcelごと落ちます
Option Explicit
'===============================================
Type WAVEFORMAT
wFormatTag As Integer
nChannels As Integer
nSamplesPerSec As Long
nAvgBytesPerSec As Long
nBlockAlign As Integer
wBitsPerSample As Integer
cbSize As Integer
End Type
Type WAVEHDR
lpData() As Byte
dwBufferLength As Long
dwBytesRecorded As Long
dwUser As Long
dwFlags As Long
dwLoops As Long
lpNext As Long
Reserved As Long
End Type
'----------------------------------------------------
Declare Function waveOutOpen Lib "winmm.dll" _
(hWaveOut As Long, _
uDeviceID As Long, _
format As WAVEFORMAT, _
dwCallback As Long, _
fPlaying As Boolean, _
dwFlags As Long) As Long
Declare Function waveOutPrepareHeader Lib "winmm.dll" _
(hWaveIn As Long, _
lpWaveInHdr As WAVEHDR, _
uSize As Long) As Long
Declare Function waveOutWrite Lib "winmm.dll" _
(hWaveOut As Long, _
lpWaveOutHdr As WAVEHDR, _
uSize As Long) As Long
Declare Function waveOutGetErrorText Lib "winmm.dll" Alias "waveInGetErrorTextA" _
(err As Long, _
lpText As String, _
uSize As Long) As Long
Declare Function waveOutReset Lib "winmm.dll" (ByVal hWaveIn As Long) As Long
Declare Function waveOutUnprepareHeader Lib "winmm.dll" _
(ByVal hWaveIn As Long, _
lpWaveInHdr As WAVEHDR, _
ByVal uSize As Long) As Long
Declare Function waveOutClose Lib "winmm.dll" (ByVal hWaveIn As Long) As Long
'----------------------------------------------------
Public Const CALLBACK_FUNCTION = &H30000
Public Const CALLBACK_NULL = 0
Public Const CALLBACK_WINDOW = &H10000
Public Const WHDR_BEGINLOOP = 4
Public Const WHDR_ENDLOOP = 8
Public Const MM_WOM_DONE = &H3BD
Public Const MMSYSERR_NOERROR = 0
Public Const WAVE_FORMAT_PCM = 1
Public Const PIE = 3.141592
'----------------------------------------------------
Dim rc As Long 'return code
Dim hmem(1) As Long ' memory handles
Dim pmem(1) As Long ' memory pointers
Dim hdr(1) As WAVEHDR ' wave headers
Dim hWaveOut As Long ' waveout handle
Dim msg As String * 250 ' message buffer
Dim hwnd As Long ' window handle
'====================================================
Sub main()
Dim a
a = play()
End Sub
Public Function play() As Boolean
Dim wfe As WAVEFORMAT
Dim whdr As WAVEHDR
Dim wave() As Byte
wfe.wFormatTag = WAVE_FORMAT_PCM
wfe.nChannels = 2
wfe.wBitsPerSample = 8
wfe.nBlockAlign = wfe.nChannels * wfe.wBitsPerSample / 8
wfe.nSamplesPerSec = 8000
wfe.nAvgBytesPerSec = wfe.nSamplesPerSec * wfe.nBlockAlign
rc = waveOutOpen(hWaveOut, 0, wfe, 0, 0, 0)
If (rc <> MMSYSERR_NOERROR) Then
waveOutGetErrorText rc, msg, Len(msg)
MsgBox msg
play = False
Exit Function
End If
Dim i
For i = 0 To wfe.nAvgBytesPerSec - 1
ReDim wave(i)
Next
For i = 0 To wfe.nAvgBytesPerSec - 1
wave(i) = 128 + 64 * Sin(2 * PIE * i * 440 / wfe.nAvgBytesPerSec)
Next
whdr.lpData = wave
whdr.dwBufferLength = wfe.nAvgBytesPerSec * 2
whdr.dwFlags = WHDR_BEGINLOOP & WHDR_ENDLOOP
whdr.dwLoops = 1
rc = waveOutPrepareHeader(hWaveOut, whdr, Len(whdr))
If (rc <> MMSYSERR_NOERROR) Then
waveOutGetErrorText rc, msg, Len(msg)
MsgBox msg
End If
rc = waveOutWrite(hWaveOut, whdr, Len(whdr))
If (rc <> MMSYSERR_NOERROR) Then
waveOutGetErrorText rc, msg, Len(msg)
MsgBox msg
End If
rc = waveOutReset(hWaveOut)
If (rc <> MMSYSERR_NOERROR) Then
waveOutGetErrorText rc, msg, Len(msg)
MsgBox msg
End If
rc = waveOutUnprepareHeader(hWaveOut, whdr, Len(whdr))
If (rc <> MMSYSERR_NOERROR) Then
waveOutGetErrorText rc, msg, Len(msg)
MsgBox msg
End If
rc = waveOutClose(hWaveOut)
If (rc <> MMSYSERR_NOERROR) Then
waveOutGetErrorText rc, msg, Len(msg)
MsgBox msg
End If
End Function
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
