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 Long, ByVal uDeviceID As Long, lpFormat As WAVEFORMATEX, ByVal dwCallback As Long, ByVal dwInstance As Long, ByVal 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 Long, ByVal lpText As String, ByVal 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 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
'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 Any, ByVal 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 Long, ByVal Msg As Long, ByVal dwInstance As Long, ByRef 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 Integer, ByVal RecordingSampleRate As Long, ByVal BufferSizeInSecondsOrZero As Single, ByVal 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 Integer, ByVal BufferArrayWriteStartPos As Long, ByVal BufferArrayWriteLength As Long, ByVal 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]