[VB6] - Vocoder.

http://www.youtube.com/watch?v=KCXZpd-pEkg

Hello everyone. Creating music, I've seen a lot of different virtual instruments and effects. One of the most interesting effects is the vocoder, which allows you to modulate his voice and make it look like a voice for example a robot or something like that. Vocoder was originally used to compress the voice data, and then it began to be used in the music industry. Because I had free time, I decided to write something like this for the sake of the experiment and describe in detail the stages of development for VB6.
So, take a look at the simplest scheme vocoder:
http://s7.hostingkartinok.com/upload...937e8d5b75.png
The signal from the microphone (speech) is fed to a bank of bandpass filters, each of which passes only a small part of the frequency band of the speech signal. The greater the number of filters - the better speech intelligibility. At the same time, the carrier signal (e.g. ramp) is also passed through the same filter bank. Filter output speech signal is fed to envelope detectors which control modulators and outputs a filter carrier signal passes to the other input of the modulator. As a result, each band speech signal adjusts the level of the corresponding band carrier (modulates it). Further, output signals from all modulators are mixed and sent to the output. Further, all signal modulators are mixed and sent to the output. In order to improve speech intelligibility also apply additional blocks, such as the detector "sizzling" sound. So, to begin development necessary to determine the source signals, where they will take. It is possible for example to capture data from a file or directly processed in real-time from a microphone or line input. To test very easy to use file, so we will do and so and so. As the carrier will use an external file looped in a circle, to adjust the tone simply add the ability to change the playback speed, which will change the tone. To capture the sound of the file will use Audio Compression Manager (ACM), with it very convenient to make conversion between formats (because the file can be in any format, you would have to write some functions to different formats). It may be that to convert to the desired format will not correct ACM drivers, then play this file will not be available (although you can try to do it in 2 stages). As input files will use the wav - files, because to work with them in the system has special features to facilitate retrieving data from them.

clsTrickWavConverter.cls:

Code:

---

' // clsTrickWavConverter.cls - class for wav conversion using ACM
' // © Krivous Anatoly Anatolevich (The trick), 2014

Option Explicit

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

Private Type ACMSTREAMHEADER
    cbStruct        As Long
    fdwStatus      As Long
    lpdwUser        As Long
    lppbSrc        As Long
    cbSrcLength    As Long
    cbSrcLengthUsed As Long
    lpdwSrcUser    As Long
    lppbDst        As Long
    cbDstLength    As Long
    cbDstLengthUsed As Long
    lpdwDstUser    As Long
    dwDriver(9)    As Long
End Type

Private Type MMCKINFO
    ckid            As Long
    ckSize          As Long
    fccType        As Long
    dwDataOffset    As Long
    dwFlags        As Long
End Type

Private Declare Function acmStreamClose Lib "msacm32" (ByVal has As Long, ByVal fdwClose As Long) As Long
Private Declare Function acmStreamConvert Lib "msacm32" (ByVal has As Long, ByRef pash As ACMSTREAMHEADER, ByVal fdwConvert As Long) As Long
Private Declare Function acmStreamMessage Lib "msacm32" (ByVal has As Long, ByVal uMsg As Long, ByVal lParam1 As Long, ByVal lParam2 As Long) As Long
Private Declare Function acmStreamOpen Lib "msacm32" (phas As Any, ByVal had As Long, pwfxSrc As WAVEFORMATEX, pwfxDst As WAVEFORMATEX, pwfltr As Any, dwCallback As Any, dwInstance As Any, ByVal fdwOpen As Long) As Long
Private Declare Function acmStreamPrepareHeader Lib "msacm32" (ByVal has As Long, ByRef pash As ACMSTREAMHEADER, ByVal fdwPrepare As Long) As Long
Private Declare Function acmStreamReset Lib "msacm32" (ByVal has As Long, ByVal fdwReset As Long) As Long
Private Declare Function acmStreamSize Lib "msacm32" (ByVal has As Long, ByVal cbInput As Long, ByRef pdwOutputBytes As Long, ByVal fdwSize As Long) As Long
Private Declare Function acmStreamUnprepareHeader Lib "msacm32" (ByVal has As Long, ByRef pash As ACMSTREAMHEADER, ByVal fdwUnprepare As Long) As Long

Private Declare Function mmioClose Lib "winmm.dll" (ByVal hmmio As Long, ByVal uFlags As Long) As Long
Private Declare Function mmioDescend Lib "winmm.dll" (ByVal hmmio As Long, lpck As MMCKINFO, lpckParent As Any, ByVal uFlags As Long) As Long
Private Declare Function mmioOpen Lib "winmm.dll" Alias "mmioOpenA" (ByVal szFileName As String, lpmmioinfo As Any, ByVal dwOpenFlags As Long) As Long
Private Declare Function mmioRead Lib "winmm.dll" (ByVal hmmio As Long, pch As Any, ByVal cch As Long) As Long
Private Declare Function mmioStringToFOURCC Lib "winmm.dll" Alias "mmioStringToFOURCCA" (ByVal sz As String, ByVal uFlags As Long) As Long
Private Declare Function mmioAscend Lib "winmm.dll" (ByVal hmmio As Long, lpck As MMCKINFO, ByVal uFlags As Long) As Long

Private Const MMIO_READ                    As Long = &H0
Private Const MMIO_FINDCHUNK                As Long = &H10
Private Const MMIO_FINDRIFF                As Long = &H20
Private Const ACM_STREAMOPENF_QUERY        As Long = &H1
Private Const ACM_STREAMSIZEF_DESTINATION  As Long = &H1&
Private Const ACM_STREAMSIZEF_SOURCE        As Long = &H0&
Private Const ACM_STREAMCONVERTF_BLOCKALIGN As Long = &H4
Private Const ACM_STREAMCONVERTF_START      As Long = &H10

Private mInpFmt    As WAVEFORMATEX    ' // Input format is defined by file
Private mOutFmt    As WAVEFORMATEX    ' // Output format is defined by user
Private mDataSize  As Long            ' // Size of data in bytes
Private bufIdx      As Long            ' // Current position in input buffer
Private buffer()    As Byte            ' // Buffer
Private hStream    As Long            ' // Handle of ACM stream
Private mInit      As Boolean          ' // Whether ACM is initialized

' // Input format
Public Property Get InputNumOfChannels() As Integer
    InputNumOfChannels = mInpFmt.nChannels
End Property
Public Property Get InputSamplesPerSecond() As Integer
    InputSamplesPerSecond = mInpFmt.nSamplesPerSec
End Property
Public Property Get InputBitPerSample() As Integer
    InputBitPerSample = mInpFmt.wBitsPerSample
End Property

' // Size of input data
Public Property Get InputDataSize() As Long
    InputDataSize = mDataSize
End Property

' // Current position in samples
Public Property Get InputCurrentPosition() As Long
    InputCurrentPosition = bufIdx / mInpFmt.nBlockAlign
End Property
Public Property Let InputCurrentPosition(ByVal Value As Long)
    Dim index As Long
   
    index = Value * mInpFmt.nBlockAlign
   
    If index >= mDataSize Or index < 0 Then
       
        err.Raise 5
        Exit Property
       
    End If
   
    bufIdx = index
End Property

' // Output format
Public Property Get OutputNumOfChannels() As Integer
    OutputNumOfChannels = mOutFmt.nChannels
End Property
Public Property Get OutputSamplesPerSecond() As Integer
    OutputSamplesPerSecond = mOutFmt.nSamplesPerSec
End Property
Public Property Get OutputBitPerSample() As Integer
    OutputBitPerSample = mOutFmt.wBitsPerSample
End Property

' // Determines relation of output size with input size
Public Property Get Rate() As Single
    Dim outLen  As Long
    ' // Initialization check
    If Not mInit Then
        If Not Init() Then Exit Property
    End If
    acmStreamSize hStream, mDataSize, outLen, ACM_STREAMSIZEF_SOURCE
    Rate = outLen / mDataSize
End Property

' // Set output format
Public Function SetFormat(ByVal NumOfChannels As Integer, ByVal SamplesPerSecond As Long, ByVal BitPerSample As Integer) As Boolean
    Dim outFmt  As WAVEFORMATEX
    Dim ret    As Long
    ' // Check format by ACM
    With outFmt
        .wFormatTag = 1
        .nChannels = NumOfChannels
        .nSamplesPerSec = SamplesPerSecond
        .wBitsPerSample = BitPerSample
        .nBlockAlign = .wBitsPerSample \ 8 * .nChannels
        .nAvgBytesPerSec = .nSamplesPerSec * .nBlockAlign
    End With
    ' // Only if file already has been opened
    If mDataSize Then
        ' // Query to ACM can it convert input format to specified output format
        ret = acmStreamOpen(ByVal 0&, 0, mInpFmt, outFmt, ByVal 0&, ByVal 0&, ByVal 0&, ACM_STREAMOPENF_QUERY)
        If ret Then Exit Function
        ' // Close stream
        If hStream Then acmStreamClose hStream, 0
        mInit = False
    End If

    mOutFmt = outFmt
    SetFormat = True
   
End Function

' // Read a wave file and check possibility of conversion to output format
Public Function ReadWaveFile(strFileName As String) As Boolean
    Dim hIn    As Long
    Dim inf    As MMCKINFO
    Dim sInf    As MMCKINFO
    Dim inpFmt  As WAVEFORMATEX
    Dim ret    As Long
    ' // Read file
    hIn = mmioOpen(strFileName, ByVal 0, MMIO_READ)
    If (hIn = 0) Then
        MsgBox "Error opening file"
        Exit Function
    End If
    ' // Seek WAVE chunk
    inf.fccType = mmioStringToFOURCC("WAVE", 0)
    If mmioDescend(hIn, inf, ByVal 0, MMIO_FINDRIFF) Then
        mmioClose hIn, 0
        MsgBox "Is not valid file"
        Exit Function
    End If
    ' // Seek fmt chunk defined format of data
    sInf.ckid = mmioStringToFOURCC("fmt", 0)
    If mmioDescend(hIn, sInf, inf, MMIO_FINDCHUNK) Then
        mmioClose hIn, 0
        MsgBox "Format chunk not found"
        Exit Function
    End If
    ' // Check size
    If sInf.ckSize > Len(inpFmt) Then
        mmioClose hIn, 0
        MsgBox "Not supported format"
        Exit Function
    End If
    ' // Read format
    If mmioRead(hIn, inpFmt, sInf.ckSize) = -1 Then
        mmioClose hIn, 0
        MsgBox "Can't read format"
        Exit Function
    End If
    ' // Query to ACM can it convert this format to specified output format
    ret = acmStreamOpen(ByVal 0&, 0, inpFmt, mOutFmt, ByVal 0&, ByVal 0&, ByVal 0&, ACM_STREAMOPENF_QUERY)
    If ret Then
        mmioClose hIn, 0
        MsgBox "Can't convert wav file"
        Exit Function
    End If
    ' // Leave fmt chunk
    mmioAscend hIn, sInf, 0
    ' // Seek data chunk
    sInf.ckid = mmioStringToFOURCC("data", 0)
    If mmioDescend(hIn, sInf, inf, MMIO_FINDCHUNK) Then
        mmioClose hIn, 0
        MsgBox "Wave data not found"
        Exit Function
    End If
    ' // Check size
    If sInf.ckSize <= 0 Then
        mmioClose hIn, 0
        MsgBox "Invalid data size"
        Exit Function
    End If
    ' // Alloc buffer and read data
    ReDim buffer(sInf.ckSize - 1)
    If mmioRead(hIn, buffer(0), sInf.ckSize) = -1 Then
        mmioClose hIn, 0
        MsgBox "Can't read data"
        Exit Function
    End If
    ' // Close file
    mmioClose hIn, 0
    ' // Initialization of variables
    mDataSize = sInf.ckSize
    bufIdx = 0
    mInpFmt = inpFmt
    ReadWaveFile = True
   
End Function

' // Get converted data
Public Function Convert(ByVal lpOutData As Long, ByVal dwCountBytes As Long, dwCountRead As Long) As Boolean
    Dim ret            As Long
    Dim inpCountBytes  As Long
    Dim acmHdr          As ACMSTREAMHEADER
    ' // Check initialization
    If Not mInit Then
        If Not Init() Then Exit Function
    End If
    ' // Get sufficient size of input data for current query
    ret = acmStreamSize(hStream, dwCountBytes, inpCountBytes, ACM_STREAMSIZEF_DESTINATION)
    If ret Then Exit Function
    ' // Check out of range
    If inpCountBytes + bufIdx >= mDataSize Then
        inpCountBytes = mDataSize - bufIdx
       
        If inpCountBytes <= 0 Then
            Convert = True
            dwCountRead = 0
            Exit Function
        End If
       
    End If
    ' // Fill ACM header
    With acmHdr
        .cbStruct = Len(acmHdr)
        .lppbDst = lpOutData
        .lppbSrc = VarPtr(buffer(bufIdx))
        .cbDstLength = dwCountBytes
        .cbSrcLength = inpCountBytes
    End With
    ' // Preparing...
    ret = acmStreamPrepareHeader(hStream, acmHdr, 0)
    If ret Then Exit Function
    ' // Conversion...
    ret = acmStreamConvert(hStream, acmHdr, ACM_STREAMCONVERTF_BLOCKALIGN)
    ' // Release
    acmStreamUnprepareHeader hStream, acmHdr, 0
    If ret Then Exit Function
    ' // Return number of read bytes
    dwCountRead = acmHdr.cbDstLengthUsed
    bufIdx = bufIdx + acmHdr.cbSrcLengthUsed
    ' // Success
    Convert = True
   
End Function

' // ACM stream initialization
Private Function Init() As Boolean
    Dim ret As Long
    ' // Open conversion stream
    ret = acmStreamOpen(hStream, 0, mInpFmt, mOutFmt, ByVal 0&, ByVal 0&, ByVal 0&, 0)
    If ret Then Exit Function
   
    Init = True
    mInit = True
End Function

Private Sub Class_Initialize()
    ' // Default output format
    With mOutFmt
        .wFormatTag = 1
        .nChannels = 1
        .nSamplesPerSec = SampleRate
        .wBitsPerSample = 16
        .nBlockAlign = .wBitsPerSample \ 8 * .nChannels
        .nAvgBytesPerSec = .nSamplesPerSec * .nBlockAlign
    End With
End Sub

Private Sub Class_Terminate()
    If hStream Then acmStreamClose hStream, 0
End Sub

---

We examine in detail the code. To open a file is the method ReadWaveFile, as an argument it takes the name of the wav-file. Wav-file extension is a file format RIFF, which in turn is composed of blocks called chunks. So we open a file using the mmioOpen, which returns a file handle that can be used with functions with RIFF files. On success, then we begin to search for the type of chunk WAVE, for this we call mmioDescend, which fills the structure MMCKINFO information chunk, if it is found. The identifier is used chunk structure FOURCC, which is a 4 ASCII characters, which are packed into a 32-bit number (in this case, Long). As a parent chunk use NULL, as we do not have a child chunk, and as the flag pass MMIO_FINDRIFF, which sets the RIFF chunk search with a given type (in this case WAVE). So, if the function mmioDescend worked successfully, our file is a WAVE-file, and you can proceed to obtain the data format. The format of the data is stored in a chunk fmt, inside chunk WAVE (embedded chunk). For this chunk, we call again mmioDescend, just as the parent chunk pass just found WAVE-chunk, and as a flag - MMIO_FINDCHUNK, which makes the search for the specified chunk. If successful, check the size of the chunk, it must match the size of the structure WAVEFORMATEX, and if all goes well read data chunk (which are the structure WAVEFORMATEX) by calling mmioRead. So now we need to make sure whether the ACM convert data from this format you want us to. To do this, we call acmStreamOpen with flag ACM_STREAMOPENF_QUERY, which allows you to query whether the ACM to convert data between the two formats. If successful start further analysis. So we are now inside the fmt chunk, we need to go back to WAVE chunk to chunk the data request. To do this, we call mmioAscend. Further, as we did with the fmt chunk the same sequence of steps is repeated for the data chunk that contains the data directly in the format fmt chunk. Data is read into the buffer, zero out the pointer in the array at the beginning of the data (bufIdx) and fill the structure with its original format. To set the output format is the method SetFormat, which tests the ability to convert to a format file when it was opened. The main function of class clsTrickWavConverter - Convert, which converts the data from the buffer at offset bufIdx in the required format. Let's examine how it works. When you first convert the stream conversion is not already open (mInit variable defines the initialisation stream conversion), so we call the Init method that opens stream conversion through acmStreamOpen. The first parameter is a pointer to a handle stream (hStream) - it function returns a handle on success and we will use for the conversion. In case of successful initialization stream, we define the size of the data needed something to convert. Because the caller passes a pointer to the buffer and its length in bytes, we need to correctly fill the buffer, without going outside. To do this, we call acmStreamSize, which returns the required size of the data to be converted. As we pass flag ACM_STREAMSIZEF_DESTINATION, which indicates getting the size in bytes of the original data based on the buffer size of the output buffer. Next we correct size based on the initial output buffer beyond since possible that the source file for example too short or we read the data near the end of the buffer. Next we fill ACMSTREAMHEADER header describes the data conversion and prepare (fix) it to the conversion using the acmStreamPrepareHeader. After that we call acmStreamConvert, which performs the conversion. ACM_STREAMCONVERTF_BLOCKALIGN flag indicates that we convert integer blocks, in this case the block size - mInpFmt.nBlockAlign. After conversion, we have to cancel the fixation through acmStreamUnprepareHeader and returns the number of bytes returned, and move the pointer to the source buffer to the number of bytes processed.
As a capture/playback of audio use clsTrickSound class to work with sound by winmm.

clsTrickSound.cls:

Code:

---

' // clsTrickSound.cls - class for sound capture and playback
' // © Krivous Anatoly Anatolevich (The trick), 2014

Option Explicit

Private Enum MMRESULT
    MMSYSERR_NOERROR = 0
    MMSYSERR_ERROR = 1
    MMSYSERR_BADDEVICEID = 2
    MMSYSERR_NOTENABLED = 3
    MMSYSERR_ALLOCATED = 4
    MMSYSERR_INVALHANDLE = 5
    MMSYSERR_NODRIVER = 6
    MMSYSERR_NOMEM = 7
    MMSYSERR_NOTSUPPORTED = 8
    MMSYSERR_BADERRNUM = 9
    MMSYSERR_INVALFLAG = 10
    MMSYSERR_INVALPARAM = 11
    MMSYSERR_HANDLEBUSY = 12
    MMSYSERR_INVALIDALIAS = 13
    MMSYSERR_BADDB = 14
    MMSYSERR_KEYNOTFOUND = 15
    MMSYSERR_READERROR = 16
    MMSYSERR_WRITEERROR = 17
    MMSYSERR_DELETEERROR = 18
    MMSYSERR_VALNOTFOUND = 19
    MMSYSERR_NODRIVERCB = 20
    WAVERR_BADFORMAT = 32
    WAVERR_STILLPLAYING = 33
    WAVERR_UNPREPARED = 34
    MMRESULT_END
End Enum

Public Enum Errors
    CAPTURE_IS_ALREADY_RUNNING = vbObjectError Or (MMRESULT_END)
    INVALID_BUFFERS_COUNT
    NOT_INITIALIZE
    ERROR_UNAVAILABLE
    ERROR_OBJECT_FAILED
    ERROR_OPEN_DEVICE = vbObjectError Or (2 * &H100)
    ERROR_PREPARE_BUFFERS = vbObjectError Or (3 * &H100)
    ERROR_ADD_BUFFERS = vbObjectError Or (4 * &H100)
    ERROR_STARTUP = vbObjectError Or (5 * &H100)
    ERROR_STOP = vbObjectError Or (6 * &H100)
End Enum

Private Type WNDCLASSEX
    cbSize              As Long
    style              As Long
    lpfnwndproc        As Long
    cbClsextra          As Long
    cbWndExtra2        As Long
    hInstance          As Long
    hIcon              As Long
    hCursor            As Long
    hbrBackground      As Long
    lpszMenuName        As Long
    lpszClassName      As Long
    hIconSm            As Long
End Type

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

Private Type WAVEINCAPS
    wMid                As Integer
    wPid                As Integer
    vDriverVersion      As Long
    szPname(31)        As Integer
    dwFormats          As Long
    wChannels          As Integer
    wReserved1          As Integer
End Type
Private Type WAVEOUTCAPS
    wMid                As Integer
    wPid                As Integer
    vDriverVersion      As Long
    szPname(31)        As Integer
    dwFormats          As Long
    wChannels          As Integer
    wReserved          As Integer
    dwSupport          As Long
End Type

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
 
Private Type buffer
    data()              As Byte
    Header              As WAVEHDR
    Status              As Boolean
End Type

Private Type PROCESS_HEAP_ENTRY
    lpData              As Long
    cbData              As Long
    cbOverhead          As Byte
    iRegionIndex        As Byte
    wFlags              As Integer
    dwCommittedSize    As Long
    dwUnCommittedSize  As Long
    lpFirstBlock        As Long
    lpLastBlock        As Long
End Type

Private Declare Function DefWindowProc Lib "user32" Alias "DefWindowProcW" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleW" (ByVal lpModuleName As Long) As Long
Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long
Private Declare Function HeapCreate Lib "kernel32" (ByVal flOptions As Long, ByVal dwInitialSize As Long, ByVal dwMaximumSize As Long) As Long
Private Declare Function HeapDestroy Lib "kernel32" (ByVal hHeap As Long) As Long
Private Declare Function HeapAlloc Lib "kernel32" (ByVal hHeap As Long, ByVal dwFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function HeapFree Lib "kernel32" (ByVal hHeap As Long, ByVal dwFlags As Long, lpMem As Any) As Long
Private Declare Function HeapWalk Lib "kernel32" (ByVal hHeap As Long, ByRef lpEntry As PROCESS_HEAP_ENTRY) As Long
Private Declare Function HeapLock Lib "kernel32" (ByVal hHeap As Long) As Long
Private Declare Function HeapUnlock Lib "kernel32" (ByVal hHeap As Long) As Long
Private Declare Function SetEnvironmentVariable Lib "kernel32" Alias "SetEnvironmentVariableW" (ByVal lpName As Long, ByVal lpValue As Long) As Long
Private Declare Function GetEnvironmentVariable Lib "kernel32" Alias "GetEnvironmentVariableW" (ByVal lpName As Long, ByVal lpBuffer As Long, ByVal nSize As Long) As Long
Private Declare Function GetMem4 Lib "msvbvm60" (pSrc As Any, pDst As Any) As Long
Private Declare Function GetClassInfoEx Lib "user32" Alias "GetClassInfoExW" (ByVal hInstance As Long, ByVal lpClassName As Long, lpWndClassEx As WNDCLASSEX) As Long
Private Declare Function UnregisterClass Lib "user32" Alias "UnregisterClassW" (ByVal lpClassName As Long, ByVal hInstance As Long) As Long
Private Declare Function RegisterClassEx Lib "user32" Alias "RegisterClassExW" (pcWndClassEx As WNDCLASSEX) As Integer
Private Declare Function CreateWindowEx Lib "user32" Alias "CreateWindowExW" (ByVal dwExStyle As Long, ByVal lpClassName As Long, ByVal lpWindowName As Long, ByVal dwStyle As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hWndParent As Long, ByVal hMenu As Long, ByVal hInstance As Long, lpParam As Any) As Long
Private Declare Function DestroyWindow Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenW" (lpString As Any) As Long
Private Declare Function lstrcpyn Lib "kernel32" Alias "lstrcpynW" (lpString1 As Any, lpString2 As Any, ByVal iMaxLength As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Sub ZeroMemory Lib "kernel32" Alias "RtlZeroMemory" (Destination As Any, ByVal Length As Long)

Private Declare Function waveInGetNumDevs Lib "winmm.dll" () As Long
Private Declare Function waveInGetID Lib "winmm.dll" (ByVal hWaveIn As Long, lpuDeviceID As Long) As Long
Private Declare Function waveInGetDevCaps Lib "winmm.dll" Alias "waveInGetDevCapsW" (ByVal uDeviceID As Long, lpCaps As WAVEINCAPS, ByVal uSize As Long) As Long
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 MMRESULT
Private Declare Function waveInPrepareHeader Lib "winmm.dll" (ByVal hWaveIn As Long, lpWaveInHdr As WAVEHDR, ByVal uSize As Long) As MMRESULT
Private Declare Function waveInReset Lib "winmm.dll" (ByVal hWaveIn As Long) As MMRESULT
Private Declare Function waveInStart Lib "winmm.dll" (ByVal hWaveIn As Long) As MMRESULT
Private Declare Function waveInStop Lib "winmm.dll" (ByVal hWaveIn As Long) As MMRESULT
Private Declare Function waveInUnprepareHeader Lib "winmm.dll" (ByVal hWaveIn As Long, lpWaveInHdr As WAVEHDR, ByVal uSize As Long) As MMRESULT
Private Declare Function waveInClose Lib "winmm.dll" (ByVal hWaveIn As Long) As MMRESULT
Private Declare Function waveInGetErrorText Lib "winmm.dll" Alias "waveInGetErrorTextW" (ByVal err As Long, ByVal lpText As Long, ByVal uSize As Long) As MMRESULT
Private Declare Function waveInAddBuffer Lib "winmm.dll" (ByVal hWaveIn As Long, lpWaveInHdr As WAVEHDR, ByVal uSize As Long) As MMRESULT
Private Declare Function waveOutGetDevCaps Lib "winmm.dll" Alias "waveOutGetDevCapsW" (ByVal uDeviceID As Long, lpCaps As WAVEOUTCAPS, ByVal uSize As Long) As Long
Private Declare Function waveOutGetNumDevs Lib "winmm.dll" () As Long
Private Declare Function waveOutGetID Lib "winmm.dll" (ByVal hWaveOut As Long, lpuDeviceID As Long) As Long
Private Declare Function waveOutOpen Lib "winmm.dll" (lphWaveOut As Long, ByVal uDeviceID As Long, lpFormat As WAVEFORMATEX, ByVal dwCallback As Long, ByVal dwInstance As Long, ByVal dwFlags As Long) As MMRESULT
Private Declare Function waveOutPrepareHeader Lib "winmm.dll" (ByVal hWaveOut As Long, lpWaveOutHdr As WAVEHDR, ByVal uSize As Long) As MMRESULT
Private Declare Function waveOutWrite Lib "winmm.dll" (ByVal hWaveOut As Long, lpWaveOutHdr As WAVEHDR, ByVal uSize As Long) As MMRESULT
Private Declare Function waveOutUnprepareHeader Lib "winmm.dll" (ByVal hWaveOut As Long, lpWaveOutHdr As WAVEHDR, ByVal uSize As Long) As MMRESULT
Private Declare Function waveOutClose Lib "winmm.dll" (ByVal hWaveOut As Long) As MMRESULT
Private Declare Function waveOutReset Lib "winmm.dll" (ByVal hWaveOut As Long) As MMRESULT
Private Declare Function waveOutPause Lib "winmm.dll" (ByVal hWaveOut As Long) As MMRESULT
Private Declare Function waveOutRestart Lib "winmm.dll" (ByVal hWaveOut As Long) As MMRESULT

Private Const SndClass                      As String = "TrickSoundClass"
Private Const HWND_MESSAGE                  As Long = -3
Private Const WAVE_MAPPER                  As Long = -1&
Private Const CALLBACK_WINDOW              As Long = &H10000
Private Const WAVE_FORMAT_PCM              As Long = 1
Private Const MM_WIM_DATA                  As Long = &H3C0
Private Const MM_WOM_DONE                  As Long = &H3BD
Private Const WNDPROCINDEX                  As Long = 18
Private Const HEAP_CREATE_ENABLE_EXECUTE    As Long = &H40000
Private Const HEAP_NO_SERIALIZE            As Long = &H1
Private Const HEAP_ZERO_MEMORY              As Long = &H8
Private Const PROCESS_HEAP_ENTRY_BUSY      As Long = &H4
Private Const GWL_WNDPROC                  As Long = (-4)

Private Init        As Boolean              ' // Whether class is initialized
Private hwnd        As Long                ' // Handle of receiver window
Private mActive    As Boolean              ' // Whether process of capture/playback is active or not
Private mSmpCount  As Long                ' // Size of buffer in samples
Private mFormat    As WAVEFORMATEX        ' // Format of wave
Private hWaveIn    As Long                ' // Handle of capture device
Private hWaveOut    As Long                ' // Handle of playback device
Private Buffers()  As buffer              ' // Buffers array
Private bufCount    As Long                ' // Count of buffers
Private unavailable As Boolean              ' // Determine if class is unavailable
Private paused      As Boolean              ' // If pause is active
Private devCap      As Collection          ' // List of capture devices
Private devPlay    As Collection          ' // List of playback devices

Dim hHeap  As Long
Dim lpAsm  As Long

' // The event that get raised when new buffer is needed
Public Event NewData(ByVal DataPtr As Long, ByVal CountBytes As Long)

' // If capture/playback is active then true
Public Property Get IsActive() As Boolean
    IsActive = mActive
End Property

' // If capture/playback is initialized then true
Public Property Get IsUnavailable() As Boolean
    IsUnavailable = unavailable
End Property

' // If object initialization failed then ture
Public Property Get IsFailed() As Boolean
    IsFailed = Not Init
End Property

' // Size of buffer in second
Public Property Get BufferLengthSec() As Single
    BufferLengthSec = mSmpCount / mFormat.nSamplesPerSec
End Property

' // Size of buffer in samples
Public Property Get BufferLengthSamples() As Long
    BufferLengthSamples = mSmpCount
End Property

' // Sample rate
Public Property Get SampleRate() As Long
    SampleRate = mFormat.nSamplesPerSec
End Property

' // Bit per sample
Public Property Get BitsPerSample() As Integer
    BitsPerSample = mFormat.wBitsPerSample
End Property

' // Count of channels
Public Property Get Channels() As Integer
    Channels = mFormat.nChannels
End Property

' // Number of buffers
Public Property Get BuffersCount() As Byte
    BuffersCount = bufCount
End Property

' // Current capture device id
Public Property Get CurrentCaptureDeviceID() As Long
    If hWaveIn Then
        waveInGetID hWaveIn, CurrentCaptureDeviceID
    Else
        err.Raise 5
    End If
End Property

' // Current playback device id
Public Property Get CurrentPlaybackDeviceID() As Long
    If hWaveOut Then
        waveOutGetID hWaveOut, CurrentPlaybackDeviceID
    Else
        err.Raise 5
    End If
End Property

' // List of available capture devices
Public Property Get CaptureDevices() As Collection
    Dim devCount    As Long
    Dim caps        As WAVEINCAPS
    Dim idx        As Long
    Dim strLen      As Long
    Dim tmpStr      As String
   
    If devCap Is Nothing Then
   
        devCount = waveInGetNumDevs()
        Set devCap = New Collection
       
        For idx = 0 To devCount - 1
            waveInGetDevCaps idx, caps, Len(caps)
            strLen = lstrlen(caps.szPname(0))
            tmpStr = Space(strLen)
            lstrcpyn ByVal StrPtr(tmpStr), caps.szPname(0), strLen + 1
            devCap.Add tmpStr
        Next
    End If
   
    Set CaptureDevices = devCap
   
End Property

' // List of available playback devices
Public Property Get PlaybackDevices() As Collection
    Dim devCount    As Long
    Dim caps        As WAVEOUTCAPS
    Dim idx        As Long
    Dim strLen      As Long
    Dim tmpStr      As String
   
    If devPlay Is Nothing Then
       
        devCount = waveOutGetNumDevs()
        Set devPlay = New Collection
       
        For idx = 0 To devCount - 1
            waveOutGetDevCaps idx, caps, Len(caps)
            strLen = lstrlen(caps.szPname(0))
            tmpStr = Space(strLen)
            lstrcpyn ByVal StrPtr(tmpStr), caps.szPname(0), strLen + 1
            devPlay.Add tmpStr
        Next
       
    End If
   
    Set PlaybackDevices = devPlay
   
End Property

---

clsTrickSound.cls (continued):

Code:

---

' // Start the capture/playback
Public Function StartProcess() As Boolean
    Dim ret As MMRESULT
   
    If mActive And Not paused Then Exit Function
   
    If Not Init Then
        err.Raise Errors.ERROR_OBJECT_FAILED
        Exit Function
    End If
   
    If Not unavailable Then
        err.Raise Errors.NOT_INITIALIZE
        Exit Function
    End If
   
    If hWaveIn Then
   
        ret = waveInStart(hWaveIn)
        If ret Then
            err.Raise ERROR_STARTUP Or ret
            Exit Function
        End If
       
    Else
   
        Dim idx As Long
       
        If paused Then
       
            ret = waveOutRestart(hWaveOut)
           
            If ret Then
                err.Raise ERROR_STARTUP Or ret
                Exit Function
            End If
           
            paused = False
           
        Else
       
            For idx = 0 To bufCount - 1
               
                RaiseEvent NewData(Buffers(idx).Header.lpData, UBound(Buffers(idx).data) + 1)
               
                ret = waveOutWrite(hWaveOut, Buffers(idx).Header, Len(Buffers(idx).Header))
               
                If ret Then
                    err.Raise ERROR_STARTUP Or ret
                    Exit Function
                End If
               
            Next
        End If

    End If
   
    StartProcess = True
    mActive = True

End Function

' // Pause playback
Public Function PauseProcess() As Boolean
    Dim ret As MMRESULT
   
    If Not Init Then
        err.Raise Errors.ERROR_OBJECT_FAILED
        Exit Function
    End If
   
    If Not unavailable Then
        err.Raise Errors.NOT_INITIALIZE
        Exit Function
    End If
   
    If Not mActive Then Exit Function
   
    If hWaveOut Then
   
        paused = True
        waveOutPause hWaveOut
        mActive = False
           
        PauseProcess = True
       
    End If
   
End Function

' // Stop playback/capture
Public Function StopProcess() As Boolean
    Dim ret As Long
   
    If Not Init Then
        err.Raise Errors.ERROR_OBJECT_FAILED
        Exit Function
    End If
   
    If Not unavailable Then
        err.Raise Errors.NOT_INITIALIZE
        Exit Function
    End If
   
    If Not mActive Then Exit Function
   
    If hWaveIn Then
        ret = waveInStop(hWaveIn)
       
        If ret Then
            err.Raise ERROR_STOP Or ret
            Exit Function
        End If

    Else
   
        ret = waveOutReset(hWaveOut)
       
        If ret Then
            err.Raise ERROR_STOP Or ret
            Exit Function
        End If
       
    End If
   
    mActive = False
    paused = False
    StopProcess = True
   
End Function

' // Playback initialization
Public Function InitPlayback(ByVal NumOfChannels As Integer, _
                            ByVal SamplesPerSec As Long, _
                            ByVal BitsPerSample As Integer, _
                            ByVal BufferSampleCount As Long, _
                            Optional ByVal DeviceID As Long = WAVE_MAPPER, _
                            Optional ByVal BuffersCount As Byte = 4) As Boolean
    Dim ret As MMRESULT
    Dim idx As Long
   
    If Not Init Then
        err.Raise Errors.ERROR_OBJECT_FAILED
        Exit Function
    End If
   
    If unavailable Then
        err.Raise Errors.ERROR_UNAVAILABLE
        Exit Function
    End If
   
    If BuffersCount < 1 Then
        err.Raise Errors.INVALID_BUFFERS_COUNT
        Exit Function
    End If
   
    unavailable = True

    With mFormat
        .cbSize = 0
        .wFormatTag = WAVE_FORMAT_PCM
        .wBitsPerSample = BitsPerSample
        .nSamplesPerSec = SamplesPerSec
        .nChannels = NumOfChannels
        .nBlockAlign = .nChannels * .wBitsPerSample \ 8
        .nAvgBytesPerSec = .nSamplesPerSec * .nBlockAlign
    End With

    mSmpCount = BufferSampleCount - (BufferSampleCount Mod mFormat.nBlockAlign)
   
    ret = waveOutOpen(hWaveOut, DeviceID, mFormat, hwnd, 0, CALLBACK_WINDOW)
   
    If ret Then
        err.Raise ERROR_OPEN_DEVICE Or ret
        Exit Function
    End If
   
    bufCount = BuffersCount
    ReDim Buffers(BuffersCount - 1)

    For idx = 0 To BuffersCount - 1
   
        With Buffers(idx)
            ReDim .data(mSmpCount * mFormat.nBlockAlign - 1)
            .Header.lpData = VarPtr(.data(0))
            .Header.dwBufferLength = UBound(.data) + 1
            .Header.dwFlags = 0
            .Header.dwLoops = 0
           
            ret = waveOutPrepareHeader(hWaveOut, .Header, Len(.Header))
           
            .Status = ret = MMSYSERR_NOERROR
        End With
       
        If ret Then
            Clear
            err.Raise ERROR_PREPARE_BUFFERS Or ret
            Exit Function
        End If
           
    Next
       
    InitPlayback = True
           
End Function

' // Capture initialization
Public Function InitCapture(ByVal NumOfChannels As Integer, _
                            ByVal SamplesPerSec As Long, _
                            ByVal BitsPerSample As Integer, _
                            ByVal BufferSampleCount As Long, _
                            Optional ByVal DeviceID As Long = WAVE_MAPPER, _
                            Optional ByVal BuffersCount As Byte = 4) As Boolean
    Dim ret As MMRESULT
    Dim idx As Long
   
    If Not Init Then
        err.Raise Errors.ERROR_OBJECT_FAILED
        Exit Function
    End If
   
    If unavailable Then
        err.Raise Errors.ERROR_UNAVAILABLE
        Exit Function
    End If
   
    If BuffersCount < 1 Then
        err.Raise Errors.INVALID_BUFFERS_COUNT
        Exit Function
    End If
   
    unavailable = True

    With mFormat
        .cbSize = 0
        .wFormatTag = WAVE_FORMAT_PCM
        .wBitsPerSample = BitsPerSample
        .nSamplesPerSec = SamplesPerSec
        .nChannels = NumOfChannels
        .nBlockAlign = .nChannels * .wBitsPerSample \ 8
        .nAvgBytesPerSec = .nSamplesPerSec * .nBlockAlign
    End With

    mSmpCount = BufferSampleCount - (BufferSampleCount Mod mFormat.nBlockAlign)
   
    ret = waveInOpen(hWaveIn, DeviceID, mFormat, hwnd, 0, CALLBACK_WINDOW)
   
    If ret Then
        err.Raise ERROR_OPEN_DEVICE Or ret
        Exit Function
    End If
   
    bufCount = BuffersCount
    ReDim Buffers(BuffersCount - 1)

    For idx = 0 To BuffersCount - 1
   
        With Buffers(idx)
            ReDim .data(mSmpCount * mFormat.nBlockAlign - 1)
            .Header.lpData = VarPtr(.data(0))
            .Header.dwBufferLength = UBound(.data) + 1
            .Header.dwFlags = 0
            .Header.dwLoops = 0
           
            ret = waveInPrepareHeader(hWaveIn, .Header, Len(.Header))
           
            .Status = ret = MMSYSERR_NOERROR
        End With
       
        If ret Then
            Clear
            err.Raise ERROR_PREPARE_BUFFERS Or ret
            Exit Function
        End If
           
    Next
   
    For idx = 0 To BuffersCount - 1
   
        ret = waveInAddBuffer(hWaveIn, Buffers(idx).Header, Len(Buffers(idx).Header))
        If ret Then
            Clear
            err.Raise ERROR_PREPARE_BUFFERS Or ret
            Exit Function
        End If
       
    Next
   
    InitCapture = True
   
End Function

' // ------------------------------------------------------------------------------------------------------------

Private Function WndProc(ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Dim idx As Long
    Dim hdr As WAVEHDR
   
    If unavailable Then
   
        Select Case Msg
        Case MM_WIM_DATA
           
            memcpy hdr, ByVal lParam, Len(hdr)
            idx = GetBufferIndex(hdr.lpData)
           
            If idx = -1 Then Exit Function
           
            RaiseEvent NewData(hdr.lpData, mSmpCount * mFormat.nBlockAlign)
           
            waveInAddBuffer hWaveIn, Buffers(idx).Header, Len(Buffers(idx).Header)
           
            Exit Function
           
        Case MM_WOM_DONE
           
            memcpy hdr, ByVal lParam, Len(hdr)
            idx = GetBufferIndex(hdr.lpData)
           
            If idx = -1 Then Exit Function
           
            RaiseEvent NewData(hdr.lpData, mSmpCount * mFormat.nBlockAlign)
           
            waveOutWrite hWaveOut, Buffers(idx).Header, Len(Buffers(idx).Header)
           
            Exit Function
           
        End Select
       
    End If
   
    WndProc = DefWindowProc(hwnd, Msg, wParam, lParam)
   
End Function

Private Function CreateAsm() As Boolean
    Dim inIDE  As Boolean
    Dim AsmSize As Long
    Dim ptr    As Long
    Dim isFirst As Boolean

    Debug.Assert MakeTrue(inIDE)
   
    If lpAsm = 0 Then
        If inIDE Then AsmSize = &H2C Else AsmSize = &H20
        hHeap = GetPrevHeap()
       
        If hHeap = 0 Then
            hHeap = HeapCreate(HEAP_CREATE_ENABLE_EXECUTE Or HEAP_NO_SERIALIZE, 0, 0)
            If hHeap = 0 Then err.Raise 7: Exit Function
            If Not SaveCurHeap() Then HeapDestroy hHeap: hHeap = 0: err.Raise 7: Exit Function
            isFirst = True
        End If
       
        lpAsm = HeapAlloc(hHeap, HEAP_NO_SERIALIZE Or HEAP_ZERO_MEMORY, AsmSize)
       
        If lpAsm = 0 Then
            If isFirst Then HeapDestroy hHeap
            hHeap = 0
            err.Raise 7
            Exit Function
        End If
       
    End If
   
    ptr = lpAsm
   
    If inIDE Then
        CreateIDEStub (ptr): ptr = ptr + &HD
    End If
   
    CreateStackConv ptr
    CreateAsm = True
   
End Function

Private Function SaveCurHeap() As Boolean
    Dim i  As Long
    Dim out As String
   
    out = Hex(hHeap)
    For i = Len(out) + 1 To 8: out = "0" & out: Next
    SaveCurHeap = SetEnvironmentVariable(StrPtr(SndClass), StrPtr(out))
   
End Function

Private Function GetPrevHeap() As Long
    Dim out  As String
   
    out = Space(&H8)
    If GetEnvironmentVariable(StrPtr(SndClass), StrPtr(out), LenB(out)) Then GetPrevHeap = Val("&H" & out)
   
End Function

Private Function CreateStackConv(ByVal ptr As Long) As Boolean
    Dim lpMeth      As Long
    Dim vTable      As Long
   
    GetMem4 ByVal ObjPtr(Me), vTable
    GetMem4 ByVal vTable + WNDPROCINDEX * 4 + &H1C, lpMeth
   
    GetMem4 &H5450C031, ByVal ptr + &H0:    GetMem4 &H488DE409, ByVal ptr + &H4:    GetMem4 &H2474FF04, ByVal ptr + &H8
    GetMem4 &H68FAE018, ByVal ptr + &HC:    GetMem4 &H12345678, ByVal ptr + &H10:  GetMem4 &HFFFFDAE8, ByVal ptr + &H14
    GetMem4 &H10C258FF, ByVal ptr + &H18:  GetMem4 &H0, ByVal ptr + &H1C
   
    GetMem4 ObjPtr(Me), ByVal ptr + &H10                    ' Push Me
    GetMem4 lpMeth - (ptr + &H14) - 5, ByVal ptr + &H14 + 1 ' Call WndProc
   
End Function
 
Private Function CreateIDEStub(ByVal ptr As Long) As Boolean
    Dim hInstVB6    As Long
    Dim lpEbMode    As Long
    Dim hInstUser32 As Long
    Dim lpDefProc  As Long
   
    hInstVB6 = GetModuleHandle(StrPtr("vba6"))
    If hInstVB6 = 0 Then Exit Function
    hInstUser32 = GetModuleHandle(StrPtr("user32"))
    If hInstUser32 = 0 Then Exit Function
   
    lpEbMode = GetProcAddress(hInstVB6, "EbMode")
    If lpEbMode = 0 Then Exit Function
    lpDefProc = GetProcAddress(hInstUser32, "DefWindowProcW")
    If lpDefProc = 0 Then Exit Function


    GetMem4 &HFFFFFBE8, ByVal ptr + &H0:    GetMem4 &HFC8FEFF, ByVal ptr + &H4
    GetMem4 &H34566B85, ByVal ptr + &H8:    GetMem4 &H12, ByVal ptr + &HC

    GetMem4 lpEbMode - ptr - 5, ByVal ptr + 1 + 0              ' Call EbMode
    GetMem4 lpDefProc - (ptr + &HD), ByVal ptr + &H9            ' JNE  DefWindowProcW
   
    CreateIDEStub = True
   
End Function

Private Function MakeTrue(Value As Boolean) As Boolean

    Value = True
    MakeTrue = True
   
End Function

Private Sub Clear()
    Dim idx As Long
   
    unavailable = False
   
    If hWaveIn Then
       
        waveInReset hWaveIn
       
        For idx = 0 To bufCount - 1
       
            If Buffers(idx).Status Then
                waveInUnprepareHeader hWaveIn, Buffers(idx).Header, Len(Buffers(idx).Header)
            End If
           
        Next
   
        waveInClose hWaveIn
       
    Else
           
        waveOutReset hWaveOut
       
        For idx = 0 To bufCount - 1
       
            If Buffers(idx).Status Then
                waveOutUnprepareHeader hWaveOut, Buffers(idx).Header, Len(Buffers(idx).Header)
            End If
           
        Next
       
        waveOutClose hWaveOut
       
    End If
   
    hWaveIn = 0
    hWaveOut = 0
    paused = False
    mActive = False
    bufCount = 0
    Erase Buffers()
    ZeroMemory mFormat, Len(mFormat)
   
End Sub

Private Function GetBufferIndex(ByVal ptr As Long) As Long
    Dim idx As Long
   
    For idx = 0 To UBound(Buffers)
   
        If Buffers(idx).Header.lpData = ptr Then
            GetBufferIndex = idx
            Exit Function
        End If
       
    Next
   
    GetBufferIndex = -1
End Function

Private Sub Class_Initialize()
    Dim cls    As WNDCLASSEX
    Dim hUser  As Long
   
    cls.cbSize = Len(cls)
   
    If GetClassInfoEx(App.hInstance, StrPtr(SndClass), cls) = 0 Then
       
        hUser = GetModuleHandle(StrPtr("user32"))
        If hUser = 0 Then Exit Sub
       
        cls.hInstance = App.hInstance
        cls.lpfnwndproc = GetProcAddress(hUser, "DefWindowProcW")
        cls.lpszClassName = StrPtr(SndClass)
       
        If RegisterClassEx(cls) = 0 Then Exit Sub

    End If
   
    If Not CreateAsm() Then Exit Sub
 
    hwnd = CreateWindowEx(0, StrPtr(SndClass), 0, 0, 0, 0, 0, 0, HWND_MESSAGE, 0, App.hInstance, ByVal 0&)
    If hwnd = 0 Then Exit Sub
 
    SetWindowLong hwnd, GWL_WNDPROC, lpAsm
   
    Init = True

End Sub

Private Sub Class_Terminate()
   
    If Not Init Then Exit Sub
   
    Clear
   
    DestroyWindow hwnd
    UnregisterClass StrPtr(SndClass), App.hInstance
   
    If hHeap = 0 Then Exit Sub

    HeapFree hHeap, HEAP_NO_SERIALIZE, ByVal lpAsm
   
End Sub

---

Working with the winmm I will not, I can only say that as a notification window messages are used. We create for each instance of your window and wave-functions transmit it in the form of a notification message, and we are using inline assembly, treat them in a special class method after setting it as the window procedure. I also added a check there EbMode, that would not be such as in DirectSound, when you can not put a normal breakpoint using the circular buffer. The class generates an event NewData when he needed next portion of audio data during playback and when once the buffer is full when capturing. To initialize the playback method is used InitPlayback, which initializes the playback device (DeviceID) on the basis of a predetermined size and number of buffers in the queue. List of devices obtained property PlaybackDevices, which represents a collection of playback devices. Device index (starting with 0) corresponds to the desired DeviceID. To provide functions to select the device by default for a given format, then transferred to constant WAVE_MAPPER. Initialization capture produced by a method similar InitCapture; list of capture devices obtained by the method CaptureDevices. Methods StartProcess, StopProcess respectively launch process playback / recording and stop; method PauseProcess pauses playback. Appointment of the remaining properties is clear from the comments in the code.

So, the source and the modulating signals we have. Now the next step is to filter. You can go several ways: use a bank of filters (IIR, FIR), or use the FFT (FFT, fast Fourier transform) or wavelet transform. For our implementation, we take the Fourier transform of the window, because IIR filter calculation is quite a complex task, and FIR filters on the computational complexity is not very effective. (Frankly, I originally did for the implementation of IIR Butterworth filter 2nd order, but I was not satisfied with the quality and the load on the processor). With the FFT turns pretty simple. Decompose speech signal into harmonic where each element of the vector represents the information about a particular frequency (it turns out that something like a large number of band-pass filters).Also decompose the carrier signal and performs modulation. After all do the inverse Fourier transform and obtain the desired signal. It turns out that the FFT makes two tasks at once - it decomposes the signal into frequency bands (see. Diagram) and performs the mixing signal after IFFT. For our task to make the adjustment amount of the frequency bands, this allows you to configure the desired color tone. For FFT and its binding write a class clsTrickFFT:

Code:

---

' // clsTrickFFT.cls  - class for FFT transformation
' // © Krivous Anatoly Anatolevich (The trick), 2014

Option Explicit

Public Enum WindowType
    WT_RECTANGLE
    WT_TRIGANULAR
    WT_HAMMING
    WT_HANN
End Enum

Private Coef(1, 13) As Single
Private mFFTSize    As Long
Private mLog        As Long
Private mWindow()  As Single
Private mType      As WindowType

' // Window type
Public Property Get WindowType() As WindowType
    WindowType = mType
End Property
Public Property Let WindowType(ByVal Value As WindowType)

    If InitWindow(Value) Then
   
        mType = Value
       
    End If
   
End Property

' // Set size of FFT
Public Property Let FFTSize(ByVal Value As Long)
    Dim log2    As Double
   
    log2 = Log(Value) / Log(2)
    ' // Value should be power of 2
    If log2 <> Fix(log2) Then
        err.Raise 5
        Exit Property
    End If
    ' // Check out of range
    If log2 < 2 Or log2 > 16384 Then
        err.Raise 9
        Exit Property
    End If
   
    InitWindow mType
   
    mLog = log2
    mFFTSize = Value
   
End Property

' // Apply window function
Public Function ApplyWindow(data() As Single) As Boolean
    Dim index  As Long
    Dim count  As Long
   
    count = UBound(data, 2) + 1

    For index = 0 To count - 1
        data(0, index) = data(0, index) * mWindow(index)
    Next
   
    ApplyWindow = True
   
End Function

' // Convert 16-bit signed integer samples to normalize (-1...1) complex values
Public Function Convert16BitToComplex(inData() As Integer, outData() As Single) As Boolean
    Dim index  As Long

    For index = 0 To UBound(inData)
        outData(0, index) = inData(index) / 32768
        outData(1, index) = 0
    Next
   
    Convert16BitToComplex = True
   
End Function

' // Convert complex values to 16-bit real signed integer samples
Public Function ConvertComplexTo16Bit(inData() As Single, outData() As Integer) As Boolean
    Dim index  As Long
    Dim Value  As Long
   
    For index = 0 To UBound(inData, 2)
        Value = inData(0, index) * 32767
        If Value > 32767 Then Value = 32767 Else If Value < -32768 Then Value = -32768
        outData(index) = Value
    Next
   
    ConvertComplexTo16Bit = True
       
End Function

' // Apply mirroring
Public Function MakeMirror(data() As Single) As Boolean
    Dim index  As Long
    Dim pointer As Long
   
    pointer = mFFTSize - 1
   
    For index = 1 To mFFTSize \ 2 - 1
        data(0, pointer) = data(0, index)
        data(1, pointer) = -data(1, index)
        pointer = pointer - 1
    Next
   
    MakeMirror = True
   
End Function

' // Process
Public Function FFT(data() As Single, ByVal IsInverse As Boolean) As Boolean
    Dim i As Long, j As Long, n As Long, K As Long, io As Long, ie As Long, in_ As Long, nn As Long
    Dim ur As Single, ui As Single, tpr As Single, tpi As Single, tqr As Single, tqi As Single, _
        wr As Single, wi As Single, sr As Single, ti As Long, tr As Long
   
    nn = mFFTSize \ 2: ie = mFFTSize
    For n = 1 To mLog
        wr = Coef(0, mLog - n): wi = Coef(1, mLog - n)
        If IsInverse Then wi = -wi
        in_ = ie \ 2: ur = 1: ui = 0
        For j = 0 To in_ - 1
            For i = j To mFFTSize - 1 Step ie
                io = i + in_
                tpr = data(0, i) + data(0, io): tpi = data(1, i) + data(1, io)
                tqr = data(0, i) - data(0, io): tqi = data(1, i) - data(1, io)
                data(0, io) = tqr * ur - tqi * ui: data(1, io) = tqi * ur + tqr * ui
                data(0, i) = tpr: data(1, i) = tpi
            Next
            sr = ur: ur = ur * wr - ui * wi: ui = ui * wr + sr * wi
        Next
        ie = ie \ 2
    Next
    ' Перестановка
    j = 1
    For i = 1 To mFFTSize - 1
        If i < j Then
            io = i - 1: in_ = j - 1: tpr = data(0, in_): tpi = data(1, in_)
            data(0, in_) = data(0, io): data(1, in_) = data(1, io)
            data(0, io) = tpr: data(1, io) = tpi
        End If
        K = nn
        Do While K < j
            j = j - K: K = K \ 2
        Loop
        j = j + K
    Next
    If IsInverse Then FFT = True: Exit Function
    ' Нормализация
    wr = 1 / mFFTSize
    For i = 0 To mFFTSize - 1
        data(0, i) = data(0, i) * wr: data(1, i) = data(1, i) * wr
    Next
    FFT = True
   
End Function

' // Init window
Public Function InitWindow(ByVal Window As WindowType) As Boolean
    Dim index  As Long
   
    Select Case Window
    Case WT_RECTANGLE
        ReDim mWindow(mFFTSize - 1)
        For index = 0 To mFFTSize - 1
            mWindow(index) = 1
        Next
    Case WT_TRIGANULAR
        ReDim mWindow(mFFTSize - 1)
        For index = 0 To mFFTSize - 1
            mWindow(index) = IIf(index < mFFTSize \ 2, index / mFFTSize * 2, 1 - index / (mFFTSize - 1))
        Next
    Case WT_HAMMING
        ReDim mWindow(mFFTSize - 1)
        For index = 0 To mFFTSize - 1
            mWindow(index) = 0.53836 - 0.46164 * Cos(6.28318530717959 * index / (mFFTSize - 1))
        Next
    Case WT_HANN
        ReDim mWindow(mFFTSize - 1)
        For index = 0 To mFFTSize - 1
            mWindow(index) = 0.5 * (1 - Cos(6.28318530717959 * index / (mFFTSize - 1)))
        Next
    Case Else
        err.Raise 5
        Exit Function
    End Select

    InitWindow = True
   
End Function

' // Initialize turning multipliers for FFT and default size
Private Sub Class_Initialize()
    Dim n As Long, vRcoef As Variant, vIcoef As Variant
    vRcoef = Array(-1#, 0#, 0.707106781186547 _
          , 0.923879532511287, 0.98078528040323, 0.995184726672197 _
          , 0.998795456205172, 0.999698818696204, 0.999924701839145 _
          , 0.999981175282601, 0.999995293809576, 0.999998823451702 _
          , 0.999999705862882, 0.999999926465718)
    vIcoef = Array(0#, -1#, -0.707106781186547 _
        , -0.38268343236509, -0.195090322016128, -9.80171403295606E-02 _
        , -0.049067674327418, -2.45412285229122E-02, -1.22715382857199E-02 _
        , -6.1358846491544E-03, -3.0679567629659E-03, -1.5339801862847E-03 _
        , -7.669903187427E-04, -3.834951875714E-04)
    For n = 0 To 13
        Coef(0, n) = vRcoef(n): Coef(1, n) = vIcoef(n)
    Next
   
    mFFTSize = 512
    mLog = 9
    mType = WT_HAMMING
    InitWindow mType
   
End Sub

---

Convert performs "FFT" method; for the reverse transformation of the second parameter passed to True. As the use of complex numbers will form an array arr (1, x), where x - complex number, the numbers arr (0, x) - the real part, arr (1, x) - the imaginary part. Dwell on the FFT I will not, because this is a very big topic, and who are interested in the network where there are many articles accessible language explained its meaning and properties; consider only the highlights. You need to convert the original real signal put into an array of complex numbers, resetting the imaginary part (the truth is based on the properties of the FFT can still accelerate if written in the real part of the one part and the imaginary other, but I did not so complicate). After conversion, we get a set of complex coefficients which correspond to the real part of the coefficients of the cosine and imaginary - before sinus. If you imagine this in the complex plane, each coefficient is a vector whose length characterizes the amplitude of the signal at that frequency and angle - phase:

http://s7.hostingkartinok.com/upload...f732571585.gif

Also, there is a mirror effect (moire) - mirroring coefficients relative half the sampling frequency which is equal in amplitude and opposite in phase. This occurs because the sampled signal as frequency may be correctly presented only to half the sampling frequency when the frequency aliasing occurs:

http://s7.hostingkartinok.com/upload...e6a2d7cc84.gif

As can be seen initially red sinusoid has a frequency equal to two sampling periods, and gradually increases the sampling period, the frequency of the sampled signal is reduced and eventually at a sampling frequency equal to the frequency sine wave signal frequency becomes equal to 0 Hz. Because of this, the Fourier coefficients mirrored relative to half the sampling frequency. Therefore, when working with the spectrum can only handle half of the spectrum, before IFFT simply copy the second half of the mirror array make complex conjugate only (additional imaginary coefficients multiplied by -1). For this purpose the method MakeMirror. When the modulation signal, we will phase distortions occur because making the transformation to which any portion of the signal, we take this site for one period, which is repeated on both sides of the window indefinitely. And if we make any changes in the spectrum, our signals may not be the same at the edges of the window and breaks will occur (in our case, clicks). To prevent this, we multiply the signal by the weight window, which gradually decreases to the edges of the signal amplitude, and take the blocks overlapping. Because we do not need high quality sound, we will not use the weight of the window before the conversion (although should do so, because there is a blur of frequencies), and compute a "head-on" with the raw signal, transform, and perform IFFT only The results are applied window function. Also it will take the blocks with a 50% overlap at the hearing that is acceptable and fast enough. To make it clear here is clearly an example:

http://s7.hostingkartinok.com/upload...6c074d699a.gif

As you can see, we take the original signal 2 times with a shift by grabbing the second half in the second pass. After manipulation, we mixed the two signals at the overlap and outputs the first part of the second half will later be mixed with the following parts. As the window we will use the Hann window. The method ApplyWindow do it.

As mentioned above for the FFT operation, we need to take the data with overlapping and send data to the output from the ceiling. To do this, we will write a special class (clsTrickOverlappedBuffer), which will give us the data, taking the overlap:

Code:

---

' // clsTrickOverlappedBuffer.cls  - class of overlapped buffer
' // © Krivous Anatoly Anatolevich (The trick), 2014

Option Explicit

Private iBuffer()  As Single      ' // Input buffer
Private oBuffer()  As Single      ' // Output buffer
Private mInit      As Boolean      ' // Determine whether object is initialized or not
Private miWritePtr  As Long        ' // Current writing index in input buffer
Private moWritePtr  As Long        ' // Current writing index in output buffer
Private mWndSize    As Long        ' // Size of part of data for I/O
Private mOverlap    As Long        ' // Size of overlapping in samples
Private iPtr        As Long        ' // Current reading index in input buffer
Private oPtr        As Long        ' // Current reading index in output buffer
Private sampleSize  As Long        ' // Size of sample in bytes

' // Initialization
Public Function Init(ByVal windowSize As Long, ByVal overlapSizeSamples As Long) As Boolean

    If overlapSizeSamples > windowSize Or overlapSizeSamples <= 0 Then Exit Function
    If windowSize <= 0 Then Exit Function
   
    ' // Allocate buffers 2 times larger for overlapping of windowSize
    ReDim iBuffer(1, windowSize * 2 - 1)
    ReDim oBuffer(1, windowSize * 2 - 1)
   
    mInit = True
    mWndSize = windowSize
    mOverlap = overlapSizeSamples
    miWritePtr = mWndSize
   
    Init = True

End Function

' // Write frame to input buffer
Public Function WriteInputData(data() As Single) As Boolean

    memcpy iBuffer(0, miWritePtr), data(0, 0), (UBound(data, 2) + 1) * sampleSize
    miWritePtr = IIf(miWritePtr, 0, mWndSize)
    WriteInputData = True
   
End Function

' // Write frame to output buffer
Public Function WriteOutputData(data() As Single) As Boolean
    Dim sampleCount As Long
    Dim inSample    As Long
    Dim pointer    As Long
    Dim rest        As Long
   
    pointer = moWritePtr
    ' // Mix overlapped data. Check number of samples before end the buffer
    sampleCount = mWndSize * 2 - pointer
    ' // If number of samples is not enough then copy until end
    If sampleCount > mOverlap Then sampleCount = mOverlap
    ' // Mix
    For inSample = 0 To sampleCount - 1
   
        oBuffer(0, pointer) = oBuffer(0, pointer) + data(0, inSample)
        pointer = pointer + 1
       
    Next
    ' // If entire data has not copied continue from beginning
    If sampleCount < mOverlap Then
   
        pointer = 0
       
        Do While pointer < mOverlap - sampleCount
       
            oBuffer(0, pointer) = oBuffer(0, pointer) + data(0, inSample)
            pointer = pointer + 1
            inSample = inSample + 1
           
        Loop
       
    End If
   
    moWritePtr = pointer
   
    ' // Copy non-overlapped part
    sampleCount = mWndSize * 2 - pointer
    rest = mWndSize - mOverlap
    ' // Check out of range
    If sampleCount > rest Then sampleCount = rest
    ' // Direct copy
    If sampleCount Then memcpy oBuffer(0, pointer), data(0, inSample), sampleCount * sampleSize
    ' // If out of range has happened then copy to beginning
    If sampleCount < rest Then
   
        pointer = 0
        memcpy oBuffer(0, pointer), data(0, inSample), (rest - sampleCount) * sampleSize
       
    End If
   
    WriteOutputData = True
   
End Function

' // Get input buffer data
Public Function GetInputBuffer(data() As Single) As Boolean
    Dim sampleCount As Long
    ' // Get available samples until end of buffer
    sampleCount = mWndSize * 2 - iPtr
    ' // Check out of range
    If sampleCount > mWndSize Then sampleCount = mWndSize
    ' // Copy
    If sampleCount > 0 Then
        memcpy data(0, 0), iBuffer(0, iPtr), sampleCount * sampleSize
    End If
    ' // Copy to beginning if need
    If sampleCount < mWndSize Then
        memcpy data(0, sampleCount), iBuffer(0, 0), (mWndSize - sampleCount) * sampleSize
    End If
    ' // Update position
    iPtr = (iPtr + mOverlap) Mod mWndSize * 2

    GetInputBuffer = True

End Function

' // Get output buffer data
Public Function GetOutputBuffer(data() As Single) As Boolean
    Dim sampleCount As Long
    ' // Get available samples until end of buffer
    sampleCount = mWndSize * 2 - oPtr
    ' // Check out of range
    If sampleCount > mWndSize Then sampleCount = mWndSize
    ' // Copy
    If sampleCount > 0 Then
        memcpy data(0, 0), oBuffer(0, oPtr), sampleCount * sampleSize
        oPtr = oPtr + sampleCount
    End If
    ' // Copy to beginning if need
    If sampleCount < mWndSize Then
        memcpy data(0, sampleCount), oBuffer(0, 0), (mWndSize - sampleCount) * sampleSize
        oPtr = mWndSize - sampleCount
    End If

    GetOutputBuffer = True

End Function

Private Sub Class_Initialize()
    sampleSize = 8
End Sub

---

Init method initializes internal buffers storage. WriteInputData method writes data to the internal buffer of the input signal. Using this method, we write the captured signal and the carrier signal. WriteOutputData method mixes the transmitted data in an internal buffer with past data added to the previous call to this method. This method we will use to write processed data signal already modulated by using this method. GetInputBuffer and GetOutputBuffer fill the input buffer of data, taking the overlap. GetInputBuffer receives data recorded by WriteInputData, respectively GetOutputBuffer method gets the data recorded by WriteOutputData. Now consider the representation of the class itself modulator clsTrickModulator, which deals specifically with the transformation of the spectrum:

Code:

---

' // clsTrickModulator.cls  - Modulator class
' // © Krivous Anatoly Anatolevich (The trick), 2014

Option Explicit

Private mBands      As Long    ' // Number of frequency bands
Private mDryWet    As Single  ' // Balance between dry and wet signals
Private mVolume    As Single  ' // Volume
Private mLevels()  As Single  ' // Frequency response

' // Volume
Public Property Let Volume(ByVal Value As Single)
    mVolume = Value
End Property
Public Property Get Volume() As Single
    Volume = mVolume
End Property

' //  Frequency response
Public Function SetLevels(Value() As Single) As Boolean
    mLevels = Value
End Function
Public Property Get Levels(ByVal index As Long) As Single
    Levels = mLevels(index)
End Property

' // Balance
Public Property Let DryWet(ByVal Value As Single)
    If Abs(Value) > 1 Then
        err.Raise 9
        Exit Property
    End If
    mDryWet = Value
End Property
Public Property Get DryWet() As Single
    DryWet = mDryWet
End Property

' // Number of frequency bands
Public Property Let Bands(ByVal Value As Long)
    If Value > 128 Or Value <= 0 Then
        err.Raise 9
        Exit Property
    End If
    mBands = Value
End Property
Public Property Get Bands() As Long
    Bands = mBands
End Property

' // Process signal
Public Function Process(carrier() As Single, modulation() As Single) As Boolean
    Dim nCount          As Long
    Dim band            As Long
    Dim endBand        As Long
    Dim sample          As Long
    Dim samplePerBand  As Long
    Dim offsetSample    As Long
    Dim modValue        As Single
    Dim ampValue        As Single
    Dim invDryWet      As Single
    Dim FFTSize        As Long
   
    invDryWet = 1 - mDryWet
    FFTSize = (UBound(carrier, 2) + 1)
    ' // Mirror part is not processed
    nCount = FFTSize \ 2
    ' // Get number of samples per band
    samplePerBand = nCount \ mBands
    ' // Calculate amplifier coefficient
    ampValue = (Sqr(mBands) * invDryWet) / 2.5 + mDryWet
    ' // Process each band
    For band = 0 To mBands - 1
        ' // Check out of range
        endBand = band * samplePerBand + samplePerBand
        If endBand >= nCount Then endBand = nCount - 1
        ' // Clear value of spectrum for current band
        modValue = 0
        ' // Process each sample
        For sample = band * samplePerBand To endBand
            ' // Calculate value of specturum for all samples of current band
            modValue = modValue + Sqr(modulation(0, sample) * modulation(0, sample) + _
                                      modulation(1, sample) * modulation(1, sample))
        Next
        ' // Modulate current band
        For sample = band * samplePerBand To endBand
            carrier(0, sample) = ((carrier(0, sample) * modValue * invDryWet) + _
                                (modulation(0, sample) * mDryWet)) * ampValue * mLevels(sample) * mVolume
            carrier(1, sample) = ((carrier(1, sample) * modValue * invDryWet) + _
                                (modulation(1, sample) * mDryWet)) * ampValue * mLevels(sample) * mVolume
        Next
    Next
   
End Function

Private Sub Class_Initialize()
    mDryWet = 0
    mVolume = 1
End Sub

---

The class has a property Volume, which determines the level of output volume. Bands property specifies the number of bands which will be divided in modulation spectrum. For example, at a sampling rate of 44100 Hz. and the size of the FFT to 2048, we obtain the frequency resolution equal 44100/2048 ≈ 21.53 Hz. When the number of frequency bands equal to 64 will take 2048/2/64 = 16 samples (344.48 Hz) frequency for each modulation. DryWet property determines the balance between the original signal and convert the output of the modulator. SetLevels method sets an array of coefficients of the amplitude-frequency characteristic (AFC) which multiplies the signal. This will produce the equalization signal and improve the sound quality after processing. The main method - Process, which actually makes processing; analyze it in detail. First, we calculate the number of samples per band based on the properties of the Bands, and then calculate the gain of the output signal depending on the number of frequency bands - this formula was obtained experimentally. Then we go through the speech frequency bands (modulation) signal and the coefficients corresponding to each band to calculate the energy data frequencies. Earlier I wrote that the amplitude spectral component - is the length of the vector, so we'll just summarize the lengths of the vectors corresponding frequencies, it will be the energy in this frequency range. Next we are going to have carrier signal in the same spectral counts change the signal according to the calculated energy also directly calculate the output level, apply equalization. When multiplying two components of (complex number) by the amount of energy is its scalability. All these manipulations we modulate a carrier signal, a speech that we required.
Thus, all components are ready. Now all you need to build and test the function. For the user interface I developed several controls specifically for the vocoder. Describe the operation and development of each, I will not, because it will take a lot of time and tell us briefly about each of them. ctlTrickKnob - control knob that something as simple as a potentiometer. He'll understand it is a regular controller, the similarity of the same Slider, only with a circular control. ctlTrickCommand - is a normal button with support for icons and added only for appearance. ctlTrickEqualizer - most interesting control. It allows you to adjust the frequency response of the signal. His panel has a logarithmic scale, both in frequency and level, which allows for more natural hearing to change the parameters. To add a point on the response you have to press the left mouse button in an empty place, to remove the - right. If you change the frequency response of a control generates an event Change. All the controls are designed only for the vocoder so their functionality is minimal.
Now all the "throws" to the form and write the code:

Code:

---

' // frmTrickVocoder.frm  - main form of TrickVocoder
' // © Krivous Anatoly Anatolevich (The trick), 2014

Option Explicit

Dim WithEvents AudioCapture    As clsTrickSound    ' // Capture device object
Dim WithEvents AudioPlayback    As clsTrickSound    ' // Playback device object

Private inpBuffer() As Integer                      ' // Capture buffer
Private outBuffer() As Integer                      ' // Playback buffer
Private rawBuffer() As Integer                      ' // Buffer of raw data of wave file
Private plyBuffer  As clsTrickOverlappedBuffer    ' // Buffer of overlapped data of carrier
Private capBuffer  As clsTrickOverlappedBuffer    ' // BUffer of overlapped data of modulator
Private FFT        As clsTrickFFT                  ' // FFT object
Private Modulator  As clsTrickModulator            ' // Modulator
Private mFFTSize    As Long                        ' // Size of FFT
Private mOverlap    As Long                        ' // Number of overlaps
Private mRawSize    As Long                        ' // Size of raw data of buffer in samples
Private mInpFile    As String                      ' // File name, if capture from file
Private tmpCapBuf() As Single                      ' // Temporary capture buffer
Private tmpPlyBuf() As Single                      ' // Temporary playback buffer
Private wavConv    As clsTrickWavConverter        ' // Converter object of carrier signal
Private inpConv    As clsTrickWavConverter        ' // Converter object of modulation signal

' // Get capture device
Public Property Get AudioCaptureDevice() As clsTrickSound
    Set AudioCaptureDevice = AudioCapture
End Property

' // Get file name of capture, if presents
Public Property Get InputFileName() As String
    InputFileName = mInpFile
End Property

' // Close window
Private Sub btnClose_Click()
    Unload Me
End Sub

' // Open carrier signal
Private Sub btnOpenCarrier_Click()
    Dim FileName    As String
    Dim conv        As clsTrickWavConverter
    ' // Get file name
    FileName = GetFile(Me.hwnd)
   
    If Len(FileName) Then

        Set conv = New clsTrickWavConverter
        ' // If success set it as current signal
        If conv.ReadWaveFile(FileName) Then
            Set wavConv = conv
        End If
       
    End If
   
End Sub

' // Settings
Private Sub btnSettings_Click()
    Dim frm As frmSettings
    Dim cur As Long
   
    Set frm = New frmSettings
   
    frm.Show vbModal
    ' // When OK has been pressed
    If frm.Result = vbOK Then
        ' // Get current capture device
        cur = AudioCapture.CurrentCaptureDeviceID()
        ' // Clear buffer because we will hear current signal looped if failure happens
        memset inpBuffer(0), mFFTSize * 2, 0
       
        If frm.SelectedDevice >= AudioCapture.CaptureDevices.count Then
            ' // Capture from file
            Set inpConv = Nothing
            Set inpConv = New clsTrickWavConverter
            ' // Read file
            If Not inpConv.ReadWaveFile(frm.FileName) Then
                ' // Restore back
                InitCapture cur
               
            Else
           
                mInpFile = frm.FileName
                AudioCapture.StopProcess
               
            End If
           
        Else
            ' // Capture from device
            AudioPlayback.StopProcess
           
            If Not InitCapture(frm.SelectedDevice) Then
                InitCapture cur
            Else
                mInpFile = vbNullString
            End If
           
            On Error Resume Next
            AudioCapture.StartProcess
            AudioPlayback.StartProcess
            On Error GoTo 0
           
            If err.Number Then
                MsgBox "Error"
            End If
           
        End If
       
    End If
   
End Sub

' // Change frequency response
Private Sub equResponse_Change()
    Dim data() As Single
   
    ReDim data(mFFTSize \ 2 - 1)
    ' // Get from control
    equResponse.GetCurve data()
    ' // Set to modulator
    Modulator.SetLevels data()
   
End Sub

' // Loading of form
Private Sub Form_Load()
    ' // Set FFT size
    mFFTSize = 2048
    ' // Set overlap
    mOverlap = 2
    ' // Playback initialization
    If Not InitPlayback() Then Unload Me
    ' // Capture initialization
    If Not InitCapture() Then
        Call btnSettings_Click
    Else
        AudioCapture.StartProcess
    End If
   
    Set plyBuffer = New clsTrickOverlappedBuffer
    Set capBuffer = New clsTrickOverlappedBuffer
    ' // Set up overlapped buffers
    plyBuffer.Init mFFTSize, mFFTSize \ mOverlap
    capBuffer.Init mFFTSize, mFFTSize \ mOverlap
   
    Set FFT = New clsTrickFFT
    ' // Set size of FFT and size of window
    FFT.FFTSize = mFFTSize
    FFT.WindowType = WT_HANN
   
    Set Modulator = New clsTrickModulator
    ' // Create buffers
    ReDim tmpCapBuf(1, mFFTSize - 1)
    ReDim tmpPlyBuf(1, mFFTSize - 1)
    ReDim inpBuffer(mFFTSize - 1)
    ReDim outBuffer(mFFTSize - 1)
    ' // Refresh information
    Call equResponse_Change
    Call knbBands_Change
    Call knbMix_Change
    Call knbVolume_Change
    Call knbPitch_Change
    ' // Run playback
    AudioPlayback.StartProcess
   
    Dim hRgn    As Long
    ' // Set window region
    hRgn = CreateRoundRectRgn(0, 0, Me.ScaleWidth, Me.ScaleHeight, 2, 2)
    SetWindowRgn Me.hwnd, hRgn, False
    ' // Set icon
    SetIcon Me.hwnd
End Sub

' // New data has been obtained from capture device
Private Sub AudioCapture_NewData(ByVal DataPtr As Long, ByVal CountBytes As Long)
    ' // Copy to temporary buffer
    memcpy inpBuffer(0), ByVal DataPtr, CountBytes
End Sub

' // Playback device requires new data
Private Sub AudioPlayback_NewData(ByVal DataPtr As Long, ByVal CountBytes As Long)
    ' // Process last captured data
    Call Process
    ' // Copy
    memcpy ByVal DataPtr, outBuffer(0), CountBytes
End Sub

' // Process of last captured data
Private Sub Process()
    Dim ovrLap      As Long
    Dim ret        As Long
    Dim idx        As Long
    Dim delta      As Single
    Dim datSize    As Long
   
    If Len(mInpFile) Then
        ' // Capture from file
        inpConv.Convert VarPtr(inpBuffer(0)), mFFTSize * 2, ret
        ' // If data have ended start at beginning
        If ret < mFFTSize * 2 Then
            inpConv.InputCurrentPosition = 0
            inpConv.Convert VarPtr(inpBuffer(ret \ 2)), mFFTSize * 2 - ret, ret
        End If
       
    End If
    ' // If carrier signal is not present
    If wavConv Is Nothing Then
        ' // Copy captured data to output buffer and exit
        outBuffer = inpBuffer
        Exit Sub
       
    End If
    ' // Transform data to complex form
    FFT.Convert16BitToComplex inpBuffer(), tmpCapBuf()
    ' // Write data to overlapped buffer
    capBuffer.WriteInputData tmpCapBuf()
    ' // Get size (in samples) of carrier signal
    datSize = wavConv.Rate * wavConv.InputDataSize \ 2
   
    If datSize < mRawSize Then
        ' // Data is too small
        wavConv.Convert VarPtr(rawBuffer(0)), mRawSize * 2, ret
        ' // If data doesn't fit entirely start at beginning
        If ret * 2 <> datSize Then
       
            wavConv.InputCurrentPosition = 0
            wavConv.Convert VarPtr(rawBuffer(ret \ 2)), datSize * 2 - ret, ret
           
        End If
        ' // Loop it within data
        ret = datSize
        idx = 0
       
        Do While ret < mRawSize
       
            rawBuffer(ret) = rawBuffer(idx)
            ret = ret + 1
            idx = idx + 1
           
        Loop
        ' // Refresh position
        wavConv.InputCurrentPosition = ((wavConv.InputCurrentPosition + idx) Mod datSize)
       
    Else
        ' // Data is enough to place
        wavConv.Convert VarPtr(rawBuffer(0)), mRawSize * 2, ret
        ' // If data has ended start at beginning
        If ret < mRawSize * 2 Then
       
            wavConv.InputCurrentPosition = 0
            wavConv.Convert VarPtr(rawBuffer(ret \ 2)), mRawSize * 2 - ret, ret
        End If
       
    End If
   
    ' // Stretch array considering pitch
    delta = 2 ^ (knbPitch.Value / 12)
    For idx = 0 To mFFTSize - 1
        outBuffer(idx) = rawBuffer(Fix(idx * delta))
    Next
    ' // Convert data of carrier signal to complex form
    FFT.Convert16BitToComplex outBuffer(), tmpPlyBuf()
    ' // Write data to overlapped buffer
    plyBuffer.WriteInputData tmpPlyBuf()

    ' // For each overlap
    For ovrLap = 0 To mOverlap - 1

        ' // Get current data from overlapped buffers
        capBuffer.GetInputBuffer tmpCapBuf()
        plyBuffer.GetInputBuffer tmpPlyBuf()
        ' // Direct FFT
        FFT.FFT tmpCapBuf(), False
        FFT.FFT tmpPlyBuf(), False
        ' // Modulation
        Modulator.Process tmpPlyBuf(), tmpCapBuf()
        ' // Mirroring
        FFT.MakeMirror tmpPlyBuf()
        ' // Reverse FFT
        FFT.FFT tmpPlyBuf(), True
        ' // Apply window
        FFT.ApplyWindow tmpPlyBuf()
        ' // Write to output buffer
        plyBuffer.WriteOutputData tmpPlyBuf()

    Next
   
    ' // Get all the processed data
    plyBuffer.GetOutputBuffer tmpPlyBuf()
    ' // Convert ot 16 bit real audio data
    FFT.ConvertComplexTo16Bit tmpPlyBuf(), outBuffer()
   
End Sub

' // Capture initialization
Private Function InitCapture(Optional DeviceID As Long = -1) As Boolean
    On Error GoTo ERROR_LABEL
    Set AudioCapture = Nothing
   
    Set AudioCapture = New clsTrickSound
    AudioCapture.InitCapture 1, SampleRate, 16, mFFTSize, DeviceID
   
    InitCapture = True
   
    Exit Function
ERROR_LABEL:
   
    MsgBox "Error initialize capture", vbCritical
   
End Function

' // Playback initialization
Private Function InitPlayback(Optional DeviceID As Long = -1) As Boolean
    On Error GoTo ERROR_LABEL
    Set AudioPlayback = Nothing
   
    Set AudioPlayback = New clsTrickSound
    AudioPlayback.InitPlayback 1, SampleRate, 16, mFFTSize, DeviceID
   
    InitPlayback = True
   
    Exit Function
ERROR_LABEL:
   
    MsgBox "Error initialize playback", vbCritical
   
End Function

' // Press mouse button within window
Private Sub Form_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
    Dim pos As Currency
   
    If y <= 26 Then
        ' // If mouse was being pressed within caption of window then movement is enabled
        ReleaseCapture
        GetCursorPos pos
        SendMessage Me.hwnd, WM_NCLBUTTONDOWN, HTCAPTION, pos
       
    End If
   
End Sub

' // Change number of frequency bands
Private Sub knbBands_Change()
   
    Modulator.Bands = knbBands.Value
    knbBands.Caption = knbBands.Value
   
End Sub

' // Mix change
Private Sub knbMix_Change()
    Dim lg As Single
    ' // Logarithmic size
    lg = ((10 ^ (knbMix.Value / 50)) - 1) / 99
    Modulator.DryWet = lg
    knbMix.Caption = Format(lg, "#0.00%")
       
End Sub

' // Pitch change
Private Sub knbPitch_Change()
   
    mRawSize = -Int(-mFFTSize * (2 ^ (knbPitch.Value / 12)))
    ReDim rawBuffer(mRawSize - 1)
   
    knbPitch.Caption = Format(knbPitch.Value, "0 sem;-0 sem;non\e")
   
End Sub

' // Volume change
Private Sub knbVolume_Change()
    Dim lg As Single
    ' // Logarithmic size
    lg = ((10 ^ (knbVolume.Value / 50)) - 1) / 99
    Modulator.Volume = lg
    knbVolume.Caption = Format(lg, "#0.00%")
           
End Sub

---

When loading of form we perform initialization of all components. Capture, playing back the audio size FFT, the amount of overlap, overlapping buffers, creating buffers for integer and complex data. Next, I made a box shape with rounded corners, as use a window without frame (draw in the nonclient area had no desire). Now the whole problem is reduced to handling events - AudioPlayback_NewData and AudioCapture_NewData. First event occurs when the playback device needs another portion of the audio data, the second when the buffer capture, in which we simply copy the data into a temporary buffer from where it will take them at processing AudioPlayback_NewData. The main method - Process, in it we just do the conversion. First we check whether we capture from a file or device. To do this, we check the variable mInpFile, which specifies the name of the input file to capture. If capture is made from a file, then we are using object inpConv, which is an instance of clsTrickWavConverter, convert the data into the format you want us to. If the data is finished (the number of bytes read does not match the passed), it means that we are on the edge of the file and continue to have to start over again. Also check the carrier signal and if it is not set then just copy the input data on output and, in this case, we will hear the raw sound. Otherwise, we translate the data into a complex form (count a real part of the signal and the imaginary zero out) and puts the resulting array in an overlapping buffer. Next, start processing the carrier signal. Because carrier signal we can have a very small length (you can use one wave period), in order to optimize I will do the repetition of the signal if required. Let me explain. For example, if we have a carrier signal 10 ms and 100 ms buffer (for example), then you could just call the conversion each time using ACM overwriting the pointer to the array destination, but it is not optimal. For optimization can be converted only once, and then simply duplicate the data to the end of the array, which we did. Only then do not forget to change the position in the source file, otherwise the next phase of the reading will not be the same and will flicks. We will write to another buffer (rawBuffer). This buffer length is based on the pitch shift. For example, if we want to shift the tone for the amount of semitones (halftones), the buffer size must be rawBuffer 2^{semitones / 12} times more. Then we simply compress / stretch buffer to a value mFFTSize, which will give us the acceleration / deceleration, and as a result increase / decrease tone. After all the manipulations we write data in an overlapping buffer and start processing. To do this, we pass by the number of overlapping data and handle them. Class objects clsTrickOverlappedBuffer return us the correct data. Processing is clear from the code, as We consider in detail the performance of each class. After processing all of overlap we get the output and convert them to integer suitable for playback. As the setting uses a form frmSettings. As the list of devices using a standard listbox, just going through my drawing class. The list of devices will be added in the following order:

• A default device predetermined format
• Device 1
• Device 2
• ...
• Device n
• Capturing from a file

For testing click on the last point message is used LB_GETITEMRECT, which receives the coordinates and size of the item in the list. If this is not done then click the sheet of paper, if there is an empty space at the bottom will be equivalent to clicking on the last point. In the handler settings button in the main form frmTrickVocoder we check capture device and either open the file for conversion or initialize capture. To adjust the volume and mixing using a logarithmic scale, as the sensitivity of the human ear is not linear.

http://s7.hostingkartinok.com/upload...4bc9a42987.png

That's basically all. Thank you for your attention.
Good luck!

Hi Trick, I just wanted to say that this is a really beautiful code example. Thank you for sharing this (and other projects) on vbForums. I've learned a lot from your code.

Your clsTrickFFT example is particularly nice. Out of curiosity, have you developed a version of the class that operates on Byte arrays? I might be interested in repurposing the class to work on image data (32-bit 2D RGBA data, ideally packing two channels into each real/imaginary pair, for performance reasons, and performing horizontal/vertical FFTs in separate passes).

I've looked at porting something like FFTReal over to VB, and would be interested in seeing how it compares performance-wise to your existing implementation. Since you have a lot of experience in this area, I wanted to ask in case you have already worked on something similar.

If not, no problem. Thanks again for your great work.

Hello Tanner_H. My class clsTrickFFT work with float-numbers (complex). You can translate byte-array to float-array (Single on VB6) and use this class for image processing. Also you can use a trick that allows speed up the process: put to real-part - first part, put to imaginary-part - second part, make FFT. Because spectrum has a mirror effect, you can select the amplitude sine and cosine combine mirrors parts.

New version.
I've translated all the sources to english.
You can download it in the #11 post.

Great project!!!

maybe out of topic

On Win XP

In IDE it works, but when Compiling-linking:

Code:

---

Microsoft (R) Incremental Linker Version 9.00.30729.01
Copyright (C) Microsoft Corporation.  All rights reserved.
LINK : warning LNK4010: invalid subsystem version number 4.0; default subsystem version assumed
LINK : fatal error LNK1101: incorrect MSPDB80.DLL version; recheck installation of this product

---

Strange... because all other VB6 project works!

yes LINK.EXE and MSPDB80.DLL are not original VB6 but taken from VisualStudio9

Maybe did I miss some other DLL ?

(Files I added are take from Visual Basic 2008 Express Edition [Microsoft Visual Studio 9.0])
I added in VB98 folder even
Link.exe.config
and
mspdbsrv.exe

and the error changed to this

Code:

---

Microsoft (R) Incremental Linker Version 9.00.30729.01
Copyright (C) Microsoft Corporation.  All rights reserved.
LINK : warning LNK4010: invalid subsystem version number 4.0; default subsystem version assumed
LINK : fatal error LNK1318: Unexpected PDB error; NOT_FOUND (4) ''msobj80.dll''

---

So I added even
msobj80.dll
And Now works

this way it is created one "extra" file: "TrickVocoder.pdb"

Quote:

---

Originally Posted by reexre

this way it is created one "extra" file: "TrickVocoder.pdb"

---

Debug symbols checked in compiler options.

The code is great, thank you.

I stumbled over it while I was googeling for a solution for a VST plugin which worked with WaveLab6 but was abandoned.

May I ask you if you have perhaps in your private code such a version (a multi-band compressor), too?

Attachment 193909

Sorry i've never written audio compressors. I think it doesn't use FFT rather a filter bank (IIR) with a simple compressor on each band.