Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちらをご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

112 / 3841 ﾍﾟｰｼﾞ

←次へ　｜　前へ→


	【80242】Win32AIPのwaveOut関数を利用する方法

ななみつき - 18/11/22(木) 13:16 -


	引用なし

	パスワード

マルチバッファリングを利用して音を途切れさせずに再生させるため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