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 LongByVal uDeviceID As Long, lpWaveFormat As WAVEFORMATEX, ByVal dwCallback As LongByRef isPlaying As BooleanByVal 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 LongByVal lpText As StringByVal 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 LongByVal 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 LongByVal wMsg As LongByVal wParam As LongByVal lParam As Long) As Long
'GFATS_SendArray
Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (hpvDest As Any, hpvSource As AnyByVal 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 LongByVal Msg As LongByVal dwInstance As LongByVal wParam As LongByVal 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 IntegerByVal PlayingSampleRate As LongByVal 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]