Excel VBA質問箱 IV

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

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


25 / 74623 ←次へ | 前へ→

【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

73 hits

【80242】Win32AIPのwaveOut関数を利用する方法 ななみつき 18/11/22(木) 13:16 質問[未読]
【80243】Re:Win32AIPのwaveOut関数を利用する方法 Jaka 18/11/22(木) 17:19 発言[未読]

25 / 74623 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free