Rec 'n' Replay/GFArrayToSpeaker.bas
Attribute VB_Name = "GFArrayToSpeakermod"
Option Explicit
'(c)2003 by Louis. 'Opposite' of GFMicrophoneToArray (get array data from there, code should be similar to that code).
'View Audio Analyzer for usage info.
'Hack of a sample downloaded from www.pscode.com.
'
'NOTE: DOES NOT WORK CORRECTLY YET!
'
'GFATS_SendArray (not all listed API functions currently used)
Private Declare Function waveOutGetPosition Lib "winmm.dll" (ByVal hWaveOut As Long, lpInfo As MMTIME, ByVal uSize As Long) As Long
Private Declare Function waveOutOpen Lib "winmm.dll" (hWaveOut As Long, ByVal uDeviceID As Long, lpWaveFormat As WAVEFORMATEX, ByVal dwCallback As Long, ByRef isPlaying As Boolean, ByVal dwFlags As Long) As Long
Private Declare Function waveOutPrepareHeader Lib "winmm.dll" (ByVal hWaveIn As Long, lpWaveInHdr As WAVEHDR, ByVal uSize As Long) As Long
Private Declare Function waveOutReset Lib "winmm.dll" (ByVal hWaveIn As Long) As Long
Private Declare Function waveOutUnprepareHeader Lib "winmm.dll" (ByVal hWaveIn As Long, lpWaveInHdr As WAVEHDR, ByVal uSize As Long) As Long
Private Declare Function waveOutClose Lib "winmm.dll" (ByVal hWaveIn As Long) As Long
Private Declare Function waveOutGetDevCaps Lib "winmm.dll" Alias "waveInGetDevCapsA" (ByVal uDeviceID As Long, lpCaps As WAVEINCAPS, ByVal uSize As Long) As Long
Private Declare Function waveOutGetNumDevs Lib "winmm.dll" () As Long
Private Declare Function waveOutGetErrorText Lib "winmm.dll" Alias "waveInGetErrorTextA" (ByVal Err As Long, ByVal lpText As String, ByVal uSize As Long) As Long
Private Declare Function waveOutWrite Lib "winmm.dll" (ByVal hWaveOut As Long, lpWaveOutHdr As WAVEHDR, ByVal uSize As Long) As Long
'non‑waveIn API functions
Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalLock Lib "kernel32" (ByVal hmem As Long) As Long
Private Declare Function GlobalFree Lib "kernel32" (ByVal hmem As Long) As Long
'GFATS_StartPlaying
Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
'GFATS_SendArray
Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long)
'GFATS_WaitForBufferRequiringData
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
'waveOutProc
Private Const MM_WOM_DONE As Long = &H3BD
'GFATS_StartPlaying
Private Const CALLBACK_FUNCTION As Long = &H30000
'GFATS_SendArray
Private Type WAVEHDR
lpData As Long
dwBufferLength As Long
dwBytesRecorded As Long
dwUser As Long
dwFlags As Long
dwLoops As Long
lpNext As Long
Reserved As Long
End Type
'GFATS_SendArray
Private Type WAVEINCAPS
wMid As Integer
wPid As Integer
vDriverVersion As Long
szPname As String * 32
dwFormats As Long
wChannels As Integer
End Type
'GFATS_SendArray
Private Type WAVEFORMATEX
wFormatTag As Integer
nChannels As Integer
nSamplesPerSec As Long
nAvgBytesPerSec As Long
nBlockAlign As Integer
wBitsPerSample As Integer
cbSize As Integer
End Type
'GFATS_SendArray
Private Type MMCKINFO
ckid As Long
ckSize As Long
fccType As Long
dwDataOffset As Long
dwFlags As Long
End Type
'GFATS_SendArray
Private Type MMTIME
wType As Long
u As Long
End Type
'other
Private Const DEVICEID As Long = 0
Private Const PlayingBufferNumber As Integer = 2 'we need more than one buffer, system will use one currently 'free' one
Dim PlayingEnabledFlag As Boolean
Dim PlayingWaveOutHandle As Long
Dim PlayingBufferSize As Long
Dim PlayingBufferFilledNumber As Integer 'when just started playing this is 0
Dim PlayingRequiresDataFlag As Boolean
Dim PlayingBufferMemoryHandleArray() As Long
Dim PlayingBufferHeaderArray() As WAVEHDR
Dim PlayingBufferHeaderAddressCurrent As Long 'which header requires new data
'***CALL BACK SUBS***
Private Sub waveOutProc(ByVal WaveOutputHandle As Long, ByVal Msg As Long, ByVal dwInstance As Long, ByVal wParam As Long, ByVal lParam As Long)
'on error resume next
If (Msg = MM_WOM_DONE) Then
If (PlayingEnabledFlag) Then
PlayingRequiresDataFlag = True
PlayingBufferHeaderAddressCurrent = wParam
End If
End If
End Sub
'***END OF CALL BACK SUBS***
'***INTERFACE SUBS***
Public Function GFATS_StartPlaying(ByVal PlayingBitRate As Integer, ByVal PlayingSampleRate As Long, ByVal PlayingBufferSizeInBytes As Long) As Boolean
On Error GoTo Error: 'returns True if output is open and ready for receiving array data, False if not
Dim WAVEFORMATVar As WAVEFORMATEX
Dim Temp As Long
Dim TempInt As Integer
Dim Tempstr$
'verify
If PlayingEnabledFlag = True Then
GFATS_StartPlaying = True 'ok
Exit Function
End If
'reset
PlayingRequiresDataFlag = False 'reset (if target project should call GFATS_SendArray())
'preset
PlayingBufferSize = PlayingBufferSizeInBytes
WAVEFORMATVar.wFormatTag = 1
WAVEFORMATVar.nChannels = 1
WAVEFORMATVar.wBitsPerSample = PlayingBitRate
WAVEFORMATVar.nSamplesPerSec = PlayingSampleRate
WAVEFORMATVar.nBlockAlign = WAVEFORMATVar.nChannels * WAVEFORMATVar.wBitsPerSample / 8
WAVEFORMATVar.nAvgBytesPerSec = WAVEFORMATVar.nSamplesPerSec * WAVEFORMATVar.nBlockAlign
WAVEFORMATVar.cbSize = 0
'begin
ReDim PlayingBufferMemoryHandleArray(1 To PlayingBufferNumber) As Long
ReDim PlayingBufferHeaderArray(1 To PlayingBufferNumber) As WAVEHDR
For TempInt = 1 To PlayingBufferNumber
PlayingBufferMemoryHandleArray(TempInt) = GlobalAlloc(&H40, PlayingBufferSize)
PlayingBufferHeaderArray(TempInt).lpData = GlobalLock(PlayingBufferMemoryHandleArray(TempInt))
PlayingBufferHeaderArray(TempInt).dwBufferLength = PlayingBufferSize
PlayingBufferHeaderArray(TempInt).dwFlags = 0
PlayingBufferHeaderArray(TempInt).dwLoops = 0
Next TempInt
Temp = waveOutOpen(PlayingWaveOutHandle, DEVICEID, WAVEFORMATVar, AddressOf waveOutProc, False, CALLBACK_FUNCTION)
If (Temp) Then 'is not MMSYSERR_NOERROR
Tempstr$ = String$(1024, Chr$(0)) 'preset
Call waveOutGetErrorText(Temp, Tempstr$, Len(Tempstr$))
MsgBox "internal error in GFATS_StartPlaying() (GFArrayToSpeaker), system returned: " + Chr$(10) + Stuff_CutNullTermination(Tempstr$), vbOKOnly + vbExclamation
Call waveOutClose(PlayingWaveOutHandle) 'make sure device is closed (important, tested)
GFATS_StartPlaying = False 'error
Exit Function
End If
For TempInt = 1 To PlayingBufferNumber
Temp = waveOutPrepareHeader(PlayingWaveOutHandle, PlayingBufferHeaderArray(TempInt), Len(PlayingBufferHeaderArray(TempInt)))
If (Temp) Then
Tempstr$ = String$(1024, Chr$(0)) 'preset
Call waveOutGetErrorText(Temp, Tempstr$, Len(Tempstr$))
MsgBox "internal error in GFATS_StartPlaying() (GFArrayToSpeaker), system returned: " + Chr$(10) + Stuff_CutNullTermination(Tempstr$), vbOKOnly + vbExclamation
Call waveOutClose(PlayingWaveOutHandle) 'make sure device is closed (important, tested)
GFATS_StartPlaying = False 'error
Exit Function
End If
Next TempInt
PlayingBufferFilledNumber = 0 'reset
PlayingEnabledFlag = True 'ok
GFATS_StartPlaying = True 'ok
Exit Function
Error:
GFATS_StartPlaying = False 'error
Exit Function
End Function
Public Sub GFATS_SendArray(ByRef OutputArray() As Integer)
'on error resume next 'forward data for playing; size of passed data must not exceed orignal buffer size, but it may be smaller
Dim BufferIndex As Integer
Dim BufferLoop As Integer
'
'NOTE: the passed array must NOT BE LARGER than
'the orignal PlayingBufferSize passed to GFATS_StartPlaying.
'
'preset
If PlayingBufferFilledNumber = PlayingBufferNumber Then
For BufferLoop = 1 To PlayingBufferNumber
If VarPtr(PlayingBufferHeaderArray(BufferLoop)) = PlayingBufferHeaderAddressCurrent Then
BufferIndex = BufferLoop
Exit For
End If
Next BufferLoop
If BufferIndex = 0 Then 'verify
MsgBox "internal error in GFATS_SendArray() (GFArrayToSpeaker): buffer index unknown !", vbOKOnly + vbExclamation
Exit Sub 'error
End If
Else
BufferIndex = (PlayingBufferFilledNumber + 1)
PlayingBufferHeaderAddressCurrent = VarPtr(PlayingBufferHeaderArray(BufferIndex))
PlayingBufferFilledNumber = PlayingBufferFilledNumber + 1
End If
'verify
If PlayingEnabledFlag = False Then 'verify
'no error message
Exit Sub
End If
If (UBound(OutputArray()) * 2&) > PlayingBufferHeaderArray(BufferIndex).dwBufferLength Then 'verify (BufferIndex is 1 if sending data to ALL buffers)
MsgBox "internal error in GFATS_SendArray() (GFArrayToSpeaker): passed value invalid !", vbOKOnly + vbExclamation
Exit Sub 'error
End If
If PlayingBufferHeaderAddressCurrent = 0 Then 'verify
MsgBox "internal error in GFATS_SendArray() (GFArrayToSpeaker): buffer address unknown !", vbOKOnly + vbExclamation
Exit Sub 'error
End If
'begin
Debug.Print "SEND AT " + Time$ + "; USED BUFFER #" + CStr(BufferIndex)
PlayingBufferHeaderArray(BufferIndex).dwBufferLength = UBound(OutputArray()) * 2&
Call CopyMemory(ByVal PlayingBufferHeaderArray(BufferIndex).lpData, OutputArray(BufferIndex), PlayingBufferHeaderArray(BufferIndex).dwBufferLength)
Call waveOutWrite(PlayingWaveOutHandle, PlayingBufferHeaderArray(BufferIndex), Len(PlayingBufferHeaderArray(BufferIndex)))
PlayingRequiresDataFlag = False 'reset (important)
Exit Sub
End Sub
Public Function GFATS_StopPlaying() As Boolean
'on error resume next 'returns True if output is closed, False if not (error)
Dim TempInt As Integer
'verify
If PlayingEnabledFlag = False Then
GFATS_StopPlaying = True 'ok
Exit Function
End If
'begin
PlayingEnabledFlag = False 'reset
PlayingRequiresDataFlag = False 'reset
Call waveOutReset(PlayingWaveOutHandle) 'reset
For TempInt = 1 To PlayingBufferNumber
Call waveOutUnprepareHeader(PlayingWaveOutHandle, PlayingBufferHeaderArray(TempInt), Len(PlayingBufferHeaderArray(TempInt)))
Call GlobalFree(PlayingBufferMemoryHandleArray(TempInt))
Next
Call waveOutClose(PlayingWaveOutHandle)
GFATS_StopPlaying = True 'ok
Exit Function
Error:
GFATS_StopPlaying = False 'error
Exit Function
End Function
Public Function GFATS_IsPlaying()
'on error resume next
GFATS_IsPlaying = PlayingEnabledFlag
End Function
Public Function GFATS_IsBufferRequiringData() As Boolean
'on error resume next
GFATS_IsBufferRequiringData = (PlayingRequiresDataFlag = True) Or (PlayingBufferFilledNumber < PlayingBufferNumber)
End Function
Public Sub GFATS_WaitForBufferRequiringData() 'does not work without DoEvents (we don't use in large programs) as callback sub is not called, use GFATS_IsBufferRequiringData instead
'on error resume next 'interrupts program until new wave data must be sent to system
Do
If (GFATS_IsBufferRequiringData) Then Exit Do
Call Sleep(1) 'decrease CPU usage
Loop Until ((PlayingWaveOutHandle = 0) Or (PlayingEnabledFlag = False))
End Sub
'***END OF INTERFACE SUBS***
[END OF FILE]