GFAudioAnalyzer/GFAudioAnalyzermod.cls
VERSION 1.0 CLASS
BEGIN
MultiUse = ‑1 'True
Persistable = 0 'NotPersistable
DataBindingBehavior = 0 'vbNone
DataSourceBehavior = 0 'vbNone
MTSTransactionMode = 0 'NotAnMTSObject
END
Attribute VB_Name = "GFAudioAnalyzercls"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
'(c)2003 by Louis. Higher‑level functions that make use of the General
'Functions GFMicrophoneToArray, GFArrayToSpeaker and GFFrequencyAnalyzer.
'
'GFAARecording_AddData
Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long)
'GFAARecording
Dim RecordingBufferSize As Long
Dim RecordingBufferArray() As Integer
Dim RecordingBufferWritePos As Long
Dim RecordingReadPos As Long
'***INTERFACE SUBS***
'NOTE: use the GFAA recording functions to store 'audio array' data in memory.
'The whole stuff is absolutely compatible with 16 bit/44.1 kHz recordings,
'for other frequencies it has not been tested yet.
Public Function GFAARecording_Create(ByVal RecordingBufferSizeMaxInBytes As Long) As Boolean
On Error GoTo Error: 'important (if memory low); returns True for recording is now possible or False for not possible (error)
ReDim RecordingBufferArray(1 To (RecordingBufferSizeMaxInBytes \ 2&)) As Integer 'do first to avoid changing values below in case of an error
RecordingBufferSize = (RecordingBufferSizeMaxInBytes \ 2&)
RecordingBufferWritePos = 1 'reset
GFAARecording_Create = True
Exit Function
Error:
GFAARecording_Create = False
Exit Function
End Function
Public Function GFAARecording_AddData(ByRef DataArray() As Integer, ByVal DataArrayReadStartPos As Long, ByVal DataArrayReadLength As Long) As Boolean
'on error resume next 'returns True if whole array was 'added', False if only partially or not at all, then the recording should be finished; passed length unit is Integers
Call CopyMemory(RecordingBufferArray(RecordingBufferWritePos), DataArray(DataArrayReadStartPos), MIN(DataArrayReadLength, RecordingBufferSize ‑ RecordingBufferWritePos + 1&) * 2&) 'two bytes per Integer value
RecordingBufferWritePos = RecordingBufferWritePos + DataArrayReadLength
If RecordingBufferWritePos > RecordingBufferSize Then
GFAARecording_AddData = False 'not all data copied
Else
GFAARecording_AddData = True 'all data copied
End If
End Function
Public Function GFAARecording_Finish() As Boolean
'on error resume next 'shrinkens array if necessary
If Not (RecordingBufferWritePos > RecordingBufferSize) Then
ReDim Preserve RecordingBufferArray(1 To (RecordingBufferWritePos ‑ 1&)) As Integer
End If
End Function
Public Sub GFAARecording_PrepareRead()
'on error resume next
RecordingReadPos = 1 'reset
End Sub
Public Sub GFAARecording_SetReadPos(ByVal ReadPos As Long)
'on error resume next '1 based, not verified (don't pass trash)
RecordingReadPos = ReadPos
End Sub
Public Function GFAARecording_ReadData(ByRef DataArray() As Integer, ByVal DataArrayWritePos As Long, ByVal DataArrayWriteLength As Long) As Boolean
'on error resume next 'returns True if there's still data to read remaining, False if not; passed length unit is Integers
Call CopyMemory(DataArray(DataArrayWritePos), RecordingBufferArray(RecordingReadPos), STUFF_MIN(DataArrayWriteLength, RecordingBufferSize ‑ RecordingReadPos + 1&) * 2&) 'one Integer consists of two bytes
RecordingReadPos = RecordingReadPos + DataArrayWriteLength
If RecordingReadPos > RecordingBufferSize Then
GFAARecording_ReadData = False 'no data remaining
Else
GFAARecording_ReadData = True 'data remaining
End If
End Function
Public Function GFAARecording_GetBufferBit(ByVal Index As Long) As Integer
'on error resume next
GFAARecording_GetBufferBit = RecordingBufferArray(Index)
End Function
Public Function GFAARecording_SetBufferBit(ByVal Index As Long, ByVal BufferBit As Integer) As Boolean
'on error resume next 'returns True for success, False for error
If ((Index < 1) Or (Index > RecordingBufferSize)) Then
GFAARecording_SetBufferBit = False 'error
Else
RecordingBufferArray(Index) = BufferBit
GFAARecording_SetBufferBit = True 'ok
End If
End Function
Public Property Set GFAARecordingSize() As Long
'on error resume next
GFAARecordingSize = RecordingBufferSize
End Property
'NOTE: and now comes hard core:
'NOTE: the following function does not work correctly >>>
Public Function GFAARecording_RecordingToSpectrumSequenceArray(ByVal SpectrumArraySize As Long, ByRef SpectrumSequenceArray() As Double, ByVal SpectrumArrayStartIndex As Long, ByVal SpectrumArrayIndexNumber As Long, ByVal SpectrumTimeWindowSizeInSeconds As Single, ByVal SpectrumSmoothingEnabledFlag As Boolean, Optional ByVal RecordingBitRate As Integer = 16, Optional ByVal RecordingSampleRate As Long = 44100) As Boolean
On Error GoTo Error: 'important (if out of memory); returns True for success or false for error
Dim RecordingReadPos As Long
Dim RecordingReadPosMax As Long
Dim RecordingTimeWindowInBytes As Long
Dim DataArray() As Integer
Dim SpectrumArray() As Double
Dim SpectrumSequenceNumber As Long
Dim SpectrumSequenceIndex As Long
Dim Temp As Long
'
'NOTE: this function does the following:
'In defined steps the frequency spectrum of the recording buffer data
'is created and added to the two‑dimensional SpectrumSequenceArray().
'Use this function to create a 3‑dimensional frequency spectrum map
'(f/strength/time).
'SpectrumArraySize defines the maximum possible frequency resolution.
'
'verify
If SpectrumArraySize < 1024 Then SpectrumArraySize = 1024
If SpectrumArraySize > 131072 Then SpectrumArraySize = 131072
'preset
'
RecordingBitRate = 16 'default (no other value currently supported)
'
ReDim DataArray(0 To (SpectrumArraySize ‑ 1&)) As Integer
ReDim SpectrumArray(0 To (SpectrumArraySize ‑ 1&)) As Double
'
'begin
'
RecordingTimeWindowInBytes = CLng(SpectrumTimeWindowSizeInSeconds * CSng(RecordingSampleRate))
RecordingReadPosMax = (RecordingBufferSize ‑ RecordingSampleRate + 1&)
SpectrumSequenceNumber = DIV(RecordingReadPosMax, RecordingTimeWindowInBytes) + 1&
ReDim SpectrumSequenceArray(1 To SpectrumSequenceNumber, 1 To SpectrumArrayIndexNumber) As Double
'
For RecordingReadPos = 1 To RecordingReadPosMax Step RecordingTimeWindowInBytes
Call CopyMemory(DataArray(0), RecordingBufferArray(RecordingReadPos), SpectrumArraySize * 2&)
If SpectrumSmoothingEnabledFlag = True Then
'NOTE: smoothing has little effect and needn't to be used (not for anything).
Call GFFA_GetSpectrumArray(DataArray(), SpectrumArray(), SpectrumArraySize, GFFA_FILTERBIT_NOFILTER)
Call GFFA_SmoothSpectrumArray(SpectrumArray(), 5) 'new value is average of 11 original values
Else
Call GFFA_GetSpectrumArray(DataArray(), SpectrumArray(), SpectrumArraySize, GFFA_FILTERBIT_NOFILTER)
End If
SpectrumSequenceIndex = SpectrumSequenceIndex + 1
'Call CopyMemory( _
SpectrumSequenceArray(SpectrumSequenceIndex, 1), _
SpectrumArray(SpectrumArrayStartIndex), _
SpectrumArrayIndexNumber) 'failed for 2‑D array
For Temp = 1 To SpectrumArrayIndexNumber
SpectrumSequenceArray(SpectrumSequenceIndex, Temp) = _
SpectrumArray(SpectrumArrayStartIndex + Temp ‑ 1&)
Next Temp
Next RecordingReadPos
GFAARecording_RecordingToSpectrumSequenceArray = True 'ok
Exit Function
Error:
GFAARecording_RecordingToSpectrumSequenceArray = False 'error
Exit Function
End Function
'<<< end of function that does not work correctly
'***END OF INTERFACE SUBS***
'***OTHER***
Private Function MIN(ByVal Value1 As Long, ByVal Value2 As Long) As Long
'on error resume next
If Value1 < Value2 Then
MIN = Value1
Else
MIN = Value2
End If
End Function
Private Function MAX(ByVal Value1 As Long, ByVal Value2 As Long) As Long
'on error resume next
If Value1 > Value2 Then
MAX = Value1
Else
MAX = Value2
End If
End Function
Private Function DIV(ByVal Value As Long, ByVal Divisor As Long) As Long
'on error resume next 'how often one number 'goes into' an other
DIV = (Value ‑ (Value Mod Divisor)) \ Divisor
End Function
[END OF FILE]