GFMicrophoneToArray/GFMicrophoneToArraymod.bas

Attribute VB_Name = "GFMicrophoneToArraymod"
Option Explicit
'(c)2003 by Louis. This is a hack of a sample downloaded from www.pscode.com.
'View sample program (in this file's directory) to know how to use this module.
'
'Recoding_[Start/Stop] (not all API functions currently used)
Private Declare Function waveInOpen Lib "winmm.dll" (lphWaveIn As LongByVal uDeviceID As Long, lpFormat As WAVEFORMATEX, ByVal dwCallback As LongByVal dwInstance As LongByVal dwFlags As Long) As Long
Private Declare Function waveInPrepareHeader Lib "winmm.dll" (ByVal RecordingWaveInHandle As Long, lpWaveInHdr As WAVEHDR, ByVal uSize As Long) As Long
Private Declare Function waveInReset Lib "winmm.dll" (ByVal RecordingWaveInHandle As Long) As Long
Private Declare Function waveInStart Lib "winmm.dll" (ByVal RecordingWaveInHandle As Long) As Long
Private Declare Function waveInStop Lib "winmm.dll" (ByVal RecordingWaveInHandle As Long) As Long
Private Declare Function waveInUnprepareHeader Lib "winmm.dll" (ByVal RecordingWaveInHandle As Long, lpWaveInHdr As WAVEHDR, ByVal uSize As Long) As Long
Private Declare Function waveInClose Lib "winmm.dll" (ByVal RecordingWaveInHandle As Long) As Long
Private Declare Function waveInGetDevCaps Lib "winmm.dll" Alias "waveInGetDevCapsA" (ByVal uDeviceID As Long, lpCaps As WAVEINCAPS, ByVal uSize As Long) As Long
Private Declare Function waveInGetNumDevs Lib "winmm.dll" () As Long
Private Declare Function waveInGetErrorText Lib "winmm.dll" Alias "waveInGetErrorTextA" (ByVal Err As LongByVal lpText As StringByVal uSize As Long) As Long
Private Declare Function waveInAddBuffer Lib "winmm.dll" (ByVal RecordingWaveInHandle As Long, lpWaveInHdr 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
'GFMTA_WaitForAnyBufferFill
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
'GFMTA_CatchBuffer
Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (hpvDest As Any, hpvSource As AnyByVal cbCopy As Long)
'GFMTA_[Start/Stop]Recording
Private Const CALLBACK_FUNCTION As Long = &H30000
Private Const MM_WIM_DATA As Long = &H3C0
Private Const MMSYSERR_NOERROR As Long = 0
Private Const WHDR_DONE As Long = &H1 'if buffer is filled up
'GFMTA_[Start/Stop]Recording
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
'GFMTA_[Start/Stop]Recording
Private Type WAVEINCAPS
   wMid As Integer
   wPid As Integer
   vDriverVersion As Long
   szPname As String * 32
   dwFormats As Long
   wChannels As Integer
End Type
'GFMTA_[Start/Stop]Recording
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
'general
Private Const DEVICEID As Long = 0
Private Const RecordingBufferNumber As Integer = 16 'we need more than one buffer or there will be 'gaps', system will fill one currently usable buffer at a time
Dim RecordingEnabledFlag As Boolean
Dim RecordingWaveInHandle As Long
Dim RecordingBufferSize As Long
Dim RecordingBufferMemoryHandleArray() As Long
Dim RecordingBufferHeaderArray() As WAVEHDR

'***CALL BACK SUBS***

Private Sub waveInProc(ByVal WaveInputHandle As LongByVal Msg As LongByVal dwInstance As LongByRef WAVEHDRVar As WAVEHDR, ByVal dwParam As Long)
    'on error resume next
   If (Msg = MM_WIM_DATA) Then
      If (RecordingEnabledFlag) Then
         'hmm :‑|
      End If
   End If
End Sub

'***END OF CALL BACK SUBS***
'***INTERFACE SUBS***
'***RECORDING FUNCTIONS***

Public Function GFMTA_StartRecording(ByVal RecordingBitRate As IntegerByVal RecordingSampleRate As LongByVal BufferSizeInSecondsOrZero As SingleByVal BufferSizeInBytesOrZero As Long) As Boolean
    On Error GoTo Error: 'returns True for success (if now recording) or False for error
    Dim WAVEFORMATVar As WAVEFORMATEX
    Dim Temp As Long
    Dim TempInt As Integer
    Dim Tempstr$
    'verify
    If RecordingEnabledFlag = True Then
        GFMTA_StartRecording = True 'ok (now recording)
        Exit Function
    End If
    If (BufferSizeInSecondsOrZero = 0) And (BufferSizeInBytesOrZero = 0) Then
        MsgBox "internal error in GFMTA_StartRecording() (GFMTA): passed values invalid !", vbOKOnly + vbExclamation
        GFMTA_StartRecording = False 'error
        Exit Function
    End If
    'preset
    If (Not (BufferSizeInSecondsOrZero = 0)) And (BufferSizeInBytesOrZero = 0) Then
        RecordingBufferSize = Int(CSng(RecordingSampleRate) * BufferSizeInSecondsOrZero)
    End If
    If (BufferSizeInSecondsOrZero = 0) And (Not (BufferSizeInBytesOrZero = 0)) Then
        RecordingBufferSize = BufferSizeInBytesOrZero
    End If
    WAVEFORMATVar.wFormatTag = 1
    WAVEFORMATVar.nChannels = 1 'mono
    WAVEFORMATVar.wBitsPerSample = RecordingBitRate
    WAVEFORMATVar.nSamplesPerSec = RecordingSampleRate
    WAVEFORMATVar.nBlockAlign = WAVEFORMATVar.nChannels * WAVEFORMATVar.wBitsPerSample / 8
    WAVEFORMATVar.nAvgBytesPerSec = WAVEFORMATVar.nSamplesPerSec * WAVEFORMATVar.nBlockAlign
    WAVEFORMATVar.cbSize = Len(WAVEFORMATVar)
    'begin
    ReDim RecordingBufferMemoryHandleArray(1 To RecordingBufferNumber) As Long
    ReDim RecordingBufferHeaderArray(1 To RecordingBufferNumber) As WAVEHDR
    For TempInt = 1 To RecordingBufferNumber
        RecordingBufferMemoryHandleArray(TempInt) = GlobalAlloc(&H40, RecordingBufferSize)
        RecordingBufferHeaderArray(TempInt).lpData = GlobalLock(RecordingBufferMemoryHandleArray(TempInt))
        RecordingBufferHeaderArray(TempInt).dwBufferLength = RecordingBufferSize
        RecordingBufferHeaderArray(TempInt).dwFlags = 0
        RecordingBufferHeaderArray(TempInt).dwLoops = 0
    Next
    Temp = waveInOpen(RecordingWaveInHandle, DEVICEID, WAVEFORMATVar, AddressOf waveInProc, 0, CALLBACK_FUNCTION)
    If (Temp) Then
        Tempstr$ = String$(1024, Chr$(0)) 'preset
        Call waveInGetErrorText(Temp, Tempstr$, Len(Tempstr$))
        MsgBox "internal error in GFMTA_StartRecording() (GFMicrophoneToArray), system returned: " + Chr$(10) + Stuff_CutNullTermination(Tempstr$), vbOKOnly + vbExclamation
        Call waveInClose(RecordingWaveInHandle) 'make sure device is closed (important, tested)
        GFMTA_StartRecording = False 'error
        Exit Function
    End If
    For TempInt = 1 To RecordingBufferNumber
        Temp = waveInPrepareHeader(RecordingWaveInHandle, RecordingBufferHeaderArray(TempInt), Len(RecordingBufferHeaderArray(TempInt)))
        If (Temp) Then
            Tempstr$ = String$(1024, Chr$(0)) 'preset
            Call waveInGetErrorText(Temp, Tempstr$, Len(Tempstr$))
            MsgBox "internal error in GFMTA_StartRecording() (GFMicrophoneToArray), system returned: " + Chr$(10) + Stuff_CutNullTermination(Tempstr$), vbOKOnly + vbExclamation
            Call waveInClose(RecordingWaveInHandle) 'make sure device is closed (important, tested)
            GFMTA_StartRecording = False 'error
            Exit Function
        End If
    Next
    For TempInt = 1 To RecordingBufferNumber
        Temp = waveInAddBuffer(RecordingWaveInHandle, RecordingBufferHeaderArray(TempInt), Len(RecordingBufferHeaderArray(TempInt)))
        If (Temp) Then
            Tempstr$ = String$(1024, Chr$(0)) 'preset
            Call waveInGetErrorText(Temp, Tempstr$, Len(Tempstr$))
            MsgBox "internal error in GFMTA_StartRecording() (GFMicrophoneToArray), system returned: " + Chr$(10) + Stuff_CutNullTermination(Tempstr$), vbOKOnly + vbExclamation
            Call waveInClose(RecordingWaveInHandle) 'make sure device is closed (important, tested)
            GFMTA_StartRecording = False 'error
            Exit Function
        End If
    Next
    RecordingEnabledFlag = True
    Call waveInStart(RecordingWaveInHandle)
    GFMTA_StartRecording = True 'ok
    Exit Function
Error:
    RecordingEnabledFlag = False
    GFMTA_StartRecording = False 'error
    Exit Function
End Function

Public Function GFMTA_StopRecording() As Boolean
    On Error GoTo Error: 'returns True for success (if not recording when leaving function) or False for error
    Dim TempInt As Integer
    '
    'IMPORTANT: when having called GFMTA_StartRecording then call
    'this sub IN ANY CASE before terminating the program or the MM system
    'will sometimes not allow to re‑open the device (at least in Win98).
    '
    'verify
    If RecordingEnabledFlag = False Then
        GFMTA_StopRecording = True 'ok
        Exit Function
    End If
    'begin
    RecordingEnabledFlag = False 'reset first to avoid reading buffer
    Call waveInStop(RecordingWaveInHandle)
    Call waveInReset(RecordingWaveInHandle) 'reset
    For TempInt = 1 To RecordingBufferNumber
        Call waveInUnprepareHeader(RecordingWaveInHandle, RecordingBufferHeaderArray(TempInt), Len(RecordingBufferHeaderArray(TempInt)))
        Call GlobalFree(RecordingBufferMemoryHandleArray(TempInt))
    Next
    Call waveInClose(RecordingWaveInHandle)
    GFMTA_StopRecording = True 'ok
    Exit Function
Error:
    GFMTA_StopRecording = False 'error
    Exit Function
End Function

Public Function GFMTA_IsRecording() As Boolean
    'on error resume next
    GFMTA_IsRecording = RecordingEnabledFlag
End Function

'***END OF RECORDING FUNCTIONS***
'***BUFFER FUNCTIONS***

Public Function GFMTA_GetBufferMemoryHandle(ByVal BufferIndex As Integer) As Long
    'on error resume next 'returns buffer VarPtr or 0 for error or not recording
    If RecordingEnabledFlag = True Then
        GFMTA_GetBufferMemoryHandle = RecordingBufferHeaderArray(BufferIndex).lpData
    Else
        GFMTA_GetBufferMemoryHandle = 0
    End If
End Function

Public Function GFMTA_GetBufferSize(ByVal BufferIndex As Integer) As Long
    'on error resume next 'returns 'usable' buffer size in bytes or 0 for error or not recording
    '
    'NOTE: when we record in mono Windows will nevertheless use
    'a 'stereo buffer' (second buffer half's values are all 0).
    '
    If RecordingEnabledFlag = True Then
        GFMTA_GetBufferSize = RecordingBufferHeaderArray(BufferIndex).dwBufferLength
    Else
        GFMTA_GetBufferSize = 0
    End If
End Function

Public Function GFMTA_CatchBuffer(ByRef BufferArray() As IntegerByVal BufferArrayWriteStartPos As LongByVal BufferArrayWriteLength As LongByVal CatchBufferIndex As Integer) As Boolean
    'on error resume next 'call to copy over buffer data, pass correct values for BufferArrayWriteStartPos or there might be a crash; returns True if anything has been copied, False if not (when there's no recording)
    'verify
    Select Case BufferArrayWriteLength 'unit: bytes
    Case Is < 0
        BufferArrayWriteLength = 0
    Case Is > GFMTA_GetBufferSize(CatchBufferIndex)
        BufferArrayWriteLength = GFMTA_GetBufferSize(CatchBufferIndex)
    End Select
    If GFMTA_GetBufferMemoryHandle(CatchBufferIndex) = 0 Then 'important on WinXP
        GFMTA_CatchBuffer = False 'error
        Exit Function
    End If
    'begin
    Call CopyMemory(BufferArray(BufferArrayWriteStartPos), ByVal GFMTA_GetBufferMemoryHandle(CatchBufferIndex), BufferArrayWriteLength)
    GFMTA_CatchBuffer = True 'ok
    Exit Function
End Function

Public Function GFMTA_IsBufferFilled(ByVal BufferIndex As Integer) As Boolean
    'on error resume next 'returns True if buffer is filled (catch a buffer while recording is enabled)
    GFMTA_IsBufferFilled = (RecordingEnabledFlag = True) And (RecordingBufferHeaderArray(BufferIndex).dwFlags And WHDR_DONE)
End Function

Public Function GFMTA_WaitForAnyBufferFill() As Long
    'on error resume next 'returns index of buffer that's filled and whose data can be caught
    Dim TempInt As Integer
    'begin
    Do
        For TempInt = 1 To RecordingBufferNumber
            If (GFMTA_IsBufferFilled(TempInt)) Then
                '
                'NOTE: the target project should call GFMTA_ReUseBuffer()
                'after it has called GFMTA_CatchBuffer().
                '
                GFMTA_WaitForAnyBufferFill = TempInt
                Exit Function
            End If
        Next TempInt
        Call Sleep(1) 'decrease CPU power
    Loop Until ((RecordingWaveInHandle = 0) Or (RecordingEnabledFlag = False)) 'verify
    GFMTA_WaitForAnyBufferFill = 0 'should not happen 'Loop Until ((RecordingWaveInHandle = 0) Or (RecordingEnabledFlag = False))
    Exit Function
End Function

Public Function GFMTA_GetFilledBufferIndex() As Long
    'on error resume next 'returns index of buffer that's filled and whose data can be caught, but does not wait (also 0 may be returned for no buffer filled)
    Dim TempInt As Integer
    'begin
    For TempInt = 1 To RecordingBufferNumber
        If (GFMTA_IsBufferFilled(TempInt)) Then
            '
            'NOTE: the target project should call GFMTA_ReUseBuffer()
            'after it has called GFMTA_CatchBuffer().
            '
            GFMTA_GetFilledBufferIndex = TempInt
            Exit Function
        End If
    Next TempInt
    GFMTA_GetFilledBufferIndex = 0
    Exit Function
End Function

Public Sub GFMTA_ReUseBuffer(ByVal BufferIndex As Integer)
    'on error resume next 'call after data of buffer has been caught
    If RecordingEnabledFlag = True Then 'verify
        Call waveInAddBuffer(RecordingWaveInHandle, RecordingBufferHeaderArray(BufferIndex), Len(RecordingBufferHeaderArray(BufferIndex)))
    End If
End Sub

'***END OF BUFFER FUNCTIONS***
'***END OF INTERFACE SUBS***


[END OF FILE]