1
  1. Этот сайт использует файлы cookie. Продолжая пользоваться данным сайтом, Вы соглашаетесь на использование нами Ваших файлов cookie. Узнать больше.
Приветствуем вас,Гость, на форуме IFUD.WS. Обязательно рекомендуется к прочтению правила форума http://ifud.ws/threads/obnovleno-pravila-foruma.7759

Вокодер на VB6

Тема в разделе "Наши статьи", создана пользователем Maxim+, 2 сен 2015.

  1. TopicStarter Overlay
    Maxim+

    Maxim+

    Регистрация:
    1 сен 2015
    Сообщения:
    66
    Симпатии:
    60
    Всем привет. Создавая музыку, я видел много разных виртуальных инструментов и эффектов. Одним из интереснейших эффектов является вокодер, который позволяет промодулировать голос и сделать его например похожим на голос робота или что-то в этом духе. Вокодер изначально использовался для сжатия речевой информации, а после его начали применять в музыкальной сфере. Т.к. у меня появилось свободное время, я решил написать что-то подобное ради эксперимента и подробно описать этапы разработки на VB6.
    Итак, взглянем на простейшую схему вокодера:
    [​IMG]
    Сигнал с микрофона (речь), подается на банк полосовых фильтров, каждый из которых пропускает только небольшую часть диапазона частот речевого сигнала. Чем больше количество фильтров - тем лучше разборчивость речи. В тоже время несущий сигнал (например пилообразный) также пропускается через аналогичный банк фильтров. С выходов фильтров речевого сигнала сигнал поступает на детекторы огибающей которые управляют модуляторами, а с выходов фильтров несущей сигнал поступает на другие входы модуляторов. В итоге каждая полоса речевого сигнала регулирует уровень соответствующей полосы несущей (модулирует ее). После сигнал выходной сигнал со всех модуляторов смешивается и попадает на выход. Для повышения разборчивости речи также применяют дополнительные блоки, вроде детектора "шипящих" звуков. Итак, чтобы начать разработку нужно определиться с исходными сигналами, откуда их будем брать. Можно к примеру захватить данные из файла или напрямую обрабатывать в реальном времени с микрофонного или линейного входа. Для тестирования очень удобно пользоваться файлом, поэтому мы сделаем и так и так. В качестве несущей будем использовать внешний файл зацикленный по кругу, для регулировки тональности просто добавим возможность изменения скорости воспроизведения, что позволит менять тональность. Для захвата звука из файла будем использовать Audio Compression Manager (ACM), с ним очень удобно производить конвертирование между форматами (т.к. файл может быть любого формата, то пришлось бы писать несколько функций для разных форматов). Может так оказаться что для конвертирования в нужный формат не окажется нужного ACM драйвера, тогда воспроизведение этого файла будет недоступным (хотя можно это попробовать сделать в 2 этапа). В качестве входных файлов будем использовать wav - файлы, т.к. для работы с ними в системе есть специальные функции облегчающие получение данных из них. Вот сам исходный код класса clsTrickWavConverter:

    ' clsTrickWavConverter - класс для конвертации Wav файлов используя ACM
    ' © Кривоус Анатолий Анатольевич (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 ' Входной формат, определяется файлом
    Private mOutFmt As WAVEFORMATEX ' Выходной формат, определяется пользователем
    Private mDataSize As Long ' Размер данных в байтах
    Private bufIdx As Long ' Текущая позиция во входном буфере
    Private buffer() As Byte ' Буфер
    Private hStream As Long ' Описатель потока сжатия
    Private mInit As Boolean ' Инициализирован ли ACM
    
    ' // Входной формат
    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
    
    ' // Размер входных данных
    Public Property Get InputDataSize() As Long
    InputDataSize = mDataSize
    End Property
    
    ' // Текущая позиция в файле в отсчетах
    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
    
    ' // Выходной формат
    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
    
    ' // Отношение размеров
    Public Property Get Rate() As Single
    Dim outLen As Long
    ' Проверка на инициализированность
    If Not mInit Then
    If Not Init() Then Exit Property
    End If
    acmStreamSize hStream, mDataSize, outLen, ACM_STREAMSIZEF_SOURCE
    Rate = outLen / mDataSize
    End Property
    
    ' // Задать формат
    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
    ' Проверяем формат
    With outFmt
    .wFormatTag = 1
    .nChannels = NumOfChannels
    .nSamplesPerSec = SamplesPerSecond
    .wBitsPerSample = BitPerSample
    .nBlockAlign = .wBitsPerSample 8 * .nChannels
    .nAvgBytesPerSec = .nSamplesPerSec * .nBlockAlign
    End With
    ' Если открыт файл
    If mDataSize Then
    ' Запрашиваем у менеджера сжатия, может ли он преобразовать этот формат в нужный нам
    ret = acmStreamOpen(ByVal 0&, 0, mInpFmt, outFmt, ByVal 0&, ByVal 0&, ByVal 0&, ACM_STREAMOPENF_QUERY)
    If ret Then Exit Function
    ' Закрываем активный поток
    If hStream Then acmStreamClose hStream, 0
    mInit = False
    End If
    
    mOutFmt = outFmt
    SetFormat = True
    
    End Function
    
    ' // Читает Wav файл и проверяет возможность перекодировать в выходной формат
    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
    ' Читаем файл
    hIn = mmioOpen(strFileName, ByVal 0, MMIO_READ)
    If (hIn = 0) Then
    MsgBox "Error opening file"
    Exit Function
    End If
    ' Ищем чанк WAVE
    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
    ' Ищем чанк fmt, определяющий формат данных
    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
    ' Проверяем размер
    If sInf.ckSize > Len(inpFmt) Then
    mmioClose hIn, 0
    MsgBox "Not supported format"
    Exit Function
    End If
    ' Читаем формат
    If mmioRead(hIn, inpFmt, sInf.ckSize) = -1 Then
    mmioClose hIn, 0
    MsgBox "Can't read format"
    Exit Function
    End If
    ' Запрашиваем у менеджера сжатия, может ли он преобразовать этот формат в нужный нам
    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
    ' Выходим из чанка fmt
    mmioAscend hIn, sInf, 0
    ' Ищем чанк data с данными
    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
    ' Проверяем размер
    If sInf.ckSize <= 0 Then
    mmioClose hIn, 0
    MsgBox "Invalid data size"
    Exit Function
    End If
    ' Выделяем буфер и читаем данные
    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
    ' Закрываем файл
    mmioClose hIn, 0
    ' Инициализация переменных
    mDataSize = sInf.ckSize
    bufIdx = 0
    mInpFmt = inpFmt
    ReadWaveFile = True
    
    End Function
    
    ' // Получить сконвертированные данные
    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
    ' Проверка на инициализированность
    If Not mInit Then
    If Not Init() Then Exit Function
    End If
    ' Узнаем нужное количество данных во входном буфере для текущего запроса
    ret = acmStreamSize(hStream, dwCountBytes, inpCountBytes, ACM_STREAMSIZEF_DESTINATION)
    If ret Then Exit Function
    ' Корректируем размер с учетом выхода за пределы
    If inpCountBytes + bufIdx >= mDataSize Then
    inpCountBytes = mDataSize - bufIdx
    
    If inpCountBytes <= 0 Then
    Convert = True
    dwCountRead = 0
    Exit Function
    End If
    
    End If
    ' Заполняем заголовок преобразования
    With acmHdr
    .cbStruct = Len(acmHdr)
    .lppbDst = lpOutData
    .lppbSrc = VarPtr(buffer(bufIdx))
    .cbDstLength = dwCountBytes
    .cbSrcLength = inpCountBytes
    End With
    ' Подготавливаем к перекодировке
    ret = acmStreamPrepareHeader(hStream, acmHdr, 0)
    If ret Then Exit Function
    ' Перекодируем
    ret = acmStreamConvert(hStream, acmHdr, ACM_STREAMCONVERTF_BLOCKALIGN)
    ' Освобождаем
    acmStreamUnprepareHeader hStream, acmHdr, 0
    If ret Then Exit Function
    ' Возвращаем реальное число прочитанных байт
    dwCountRead = acmHdr.cbDstLengthUsed
    bufIdx = bufIdx + acmHdr.cbSrcLengthUsed
    ' Успех
    Convert = True
    
    End Function
    
    ' // Инициализация потока ACM
    Private Function Init() As Boolean
    Dim ret As Long
    ' Открываем поток для нужного преобразования
    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()
    ' Выходной формат по умолчанию
    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
    Разберем подробно код. Для открытия файла служит метод ReadWaveFile, в качестве аргумента он принимает имя wav-файла. Файл с расширением .wav представляет собой файл в формате Please login or register to view links, который в свою очередь состоит из блоков, называемых чанками (chunk). Итак мы открываем файл с помощью функции mmioOpen, которая возвращает хендл файла, который можно использовать с функциями работы с RIFF файлами. Если все прошло успешно, то мы начинаем поиск чанка с типом WAVE, для этого мы вызываем функциюmmioDescend, которая заполняет структуру MMCKINFO информацией о чанке, если он найден. В качестве идентификатора чанка используется структура FOURCC, которая представляет собой 4 ASCII символа, которые упакованы в 32-разрядное число (в нашем случае Long). В качестве родительского чанка используем NULL, т.к. у нас не вложенный чанк, а в качестве флага передаем MMIO_FINDRIFF, который задает поиск чанка RIFF с заданным типом (в нашем случае WAVE). Итак, если функция mmioDescend отработала успешно, то наш RIFF-файл является WAVE-файлом, и можно переходить к получению формата данных. Формат данных хранится в чанке fmt, внутри чанка WAVE (вложенный чанк). Для получения этого чанка, мы вызываем опять-таки mmioDescend, только в качестве родительского чанка передаем только что найденный WAVE-чанк, а в качестве флага - MMIO_FINDCHUNK, который заставляет искать указанный чанк. В случае успеха, проверяем размер чанка, он должен соответствовать размеру структуры WAVEFORMATEX, и если все нормально читаем данные чанка (которые представляют собой структуру WAVEFORMATEX) посредством вызова mmioRead. Итак, теперь нам нужно убедиться, сможет ли ACM конвертировать данные из этого формата в нужный нам. Для этого мы вызываем функцию acmStreamOpen с флагом ACM_STREAMOPENF_QUERY, который позволяет запросить сможет ли ACM преобразовать данные между двумя форматами. В случае успеха начинаем разбор дальше. Итак мы сейчас находимся внутри fmt чанка, нам нужно опять вернуться в WAVE чанк, чтобы запросить чанк с данными. Для этого мы вызываем функцию mmioAscend. Далее, также как мы делали с fmt чанком, такую же последовательность действий повторяем для data чанка, который содержит непосредственно данные в формате fmt чанка. Данные читаем в буфер buffer(), обнуляем указатель в массиве на начало данных (bufIdx) и заполняем структуру с исходным форматом.
    Для задания выходного формата служит метод SetFormat, который проверяет возможность конвертирования в формат файла, если он был открыт. Основная функция классаclsTrickWavConverter - Convert, которая конвертирует данные из буфера по смещению bufIdx в нужный нам формат. Рассмотрим подробнее как она работает. При первом конвертировании поток преобразования еще не открыт (переменная mInit определяет инициализированность потока преобразования), поэтому мы вызываем метод Init который открывает поток преобразования через acmStreamOpen. Первым параметром передается указатель на хендл потока (hStream) - в него функция вернет хендл в случае успеха и его мы будем использовать для конвертации. В случае успешной инициализации потока мы определяем размер данных, необходимых что-бы произвести конвертацию. Т.к. вызывающая сторона передает указатель на буфер и его длину в байтах, нам нужно корректно заполнить буфер, не выходя за пределы. Для этого мы вызываем функцию acmStreamSize, которая возвращает необходимый размер данных для конвертации. В качестве флага мы передаем ACM_STREAMSIZEF_DESTINATION, что обозначает получение размера данных в байтах исходного буфера на основании размера выходного буфера. Далее мы корректируем размер с учетом выхода за пределы исходного буфера, т.к. возможно что исходный файл например слишком короткий или мы читаем данные около конца буфера. Далее мы заполняем заголовок ACMSTREAMHEADER описывающий данные преобразования и подготавливаем (фиксируем) его к конвертации с помощью функции acmStreamPrepareHeader. После этого мы вызываем acmStreamConvert, которая выполняет конвертацию. ФлагACM_STREAMCONVERTF_BLOCKALIGN обозначает то, что мы конвертируем целое число блоков, в данном случае размер блока - mInpFmt.nBlockAlign. После конвертации мы должны отменить фиксацию через acmStreamUnprepareHeader и возвращаем число возвращенных байтов, также передвигаем указатель в исходном буфере на число обработанных байт.
    В качестве захвата/воспроизведения звука используем класс clsTrickSound для работы со звуком посредством winmm:

    ' clsTrickSound - класс для захвата и воспроизведения звука
    ' © Кривоус Анатолий Анатольевич (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 ' Корректно ли инициализирован класс
    Private hwnd As Long ' Хендл окна приемника сообщений
    Private mActive As Boolean ' Активен ли процесс захвата/воспроизведения
    Private mSmpCount As Long ' Размер буфера в семплах
    Private mFormat As WAVEFORMATEX ' Формат
    Private hWaveIn As Long ' Хендл устройства захвата
    Private hWaveOut As Long ' Хендл устройства воспроизведения
    Private Buffers() As buffer ' Буфера
    Private bufCount As Long ' Количество буферов
    Private unavailable As Boolean ' Если недоступен, то True
    Private paused As Boolean ' Если пауза
    Private devCap As Collection ' Устройства захвата
    Private devPlay As Collection ' Устройства воспроизведения

    Dim hHeap As Long
    Dim lpAsm As Long

    ' // Событие возникающее при запросе нового буфера
    Public Event NewData(ByVal DataPtr As Long, ByVal CountBytes As Long)

    ' // Если активен захват/воспроизведение то True
    Public Property Get IsActive() As Boolean
    IsActive = mActive
    End Property

    ' // Если инициализация захвата/воспроизведения успешна то True
    Public Property Get IsUnavailable() As Boolean
    IsUnavailable = unavailable
    End Property

    ' // Если ошибка инициализации объекта то True
    Public Property Get IsFailed() As Boolean
    IsFailed = Not Init
    End Property

    ' // Размер буфера в секундах
    Public Property Get BufferLengthSec() As Single
    BufferLengthSec = mSmpCount / mFormat.nSamplesPerSec
    End Property

    ' // Размер буфера в семплах
    Public Property Get BufferLengthSamples() As Long
    BufferLengthSamples = mSmpCount
    End Property

    ' // Частота дискретизации
    Public Property Get SampleRate() As Long
    SampleRate = mFormat.nSamplesPerSec
    End Property

    ' // Разрядность
    Public Property Get BitsPerSample() As Integer
    BitsPerSample = mFormat.wBitsPerSample
    End Property

    ' // Количество каналов
    Public Property Get Channels() As Integer
    Channels = mFormat.nChannels
    End Property

    ' // Количество буферов
    Public Property Get BuffersCount() As Byte
    BuffersCount = bufCount
    End Property

    ' // Текущий идентификатор устройства захвата
    Public Property Get CurrentCaptureDeviceID() As Long
    If hWaveIn Then
    waveInGetID hWaveIn, CurrentCaptureDeviceID
    Else
    err.Raise 5
    End If
    End Property

    ' // Текущий идентификатор устройства воспроизведения
    Public Property Get CurrentPlaybackDeviceID() As Long
    If hWaveOut Then
    waveOutGetID hWaveOut, CurrentPlaybackDeviceID
    Else
    err.Raise 5
    End If
    End Property

    ' // Коллекция доступных устройств захвата
    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

    ' // Коллекция доступных устройств воспроизведения
    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

    ' // Запустить захват/воспроизведение
    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, Buf#1074;<stronfers(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

    ' // Приостановить воспроизведение
    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

    ' // Остановить захват/воспроизведение
    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

    ' // Инициализация воспроизведения
    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

    ' // Инициализация захвата
    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

    Описывать работу с winmm я не буду, скажу только что в качестве уведомлений используются оконные сообщения. Мы создаем для каждого экземпляра класса свое окно и wave-функции передают ему уведомления в виде сообщений, а мы, используя ассемблерную вставку, обрабатываем их в специальном методе класса, предварительно установив его в качестве оконной процедуры. Также я добавил туда проверку EbMode, что бы не было такого как в DirectSound, когда нельзя поставить нормально брейкпоинт при использовании циркулярного буфера. Класс генерирует событие NewData когда ему нужна очередная порция звуковых данных при воспроизведении и когда очередной буфер заполнен при захвате. Для инициализации воспроизведения используется метод InitPlayback, который инициализирует устройство воспроизведения (DeviceID) исходя из заданного формата и количества буферов в очереди. Список устройств получается свойством PlaybackDevices, которое представляет коллекцию устройств воспроизведения. Индекс устройства (от 0) соответствует нужному DeviceID. Чтобы предоставить функции выбирать само устройство по умолчанию для заданного формата, то передается константа WAVE_MAPPER. Инициализация захвата производится аналогично с помощью метода InitCapture; список устройств захвата получается с помощью метода CaptureDevices. Методы StartProcess, StopProcess соответственно запускают процесс воспроизведения/записи и останавливают; метод PauseProcess приостанавливает воспроизведение. Назначение остальных свойств понятно из комментариев в коде.
    Итак, исходный сигнал и модулирующий мы имеем. Теперь следующим этапом является фильтрация. Можно пойти несколькими путями: использовать банк фильтров (БИХ, КИХ), либо использовать БПФ (FFT, быстрое преобразование Фурье) или Вейвлет-преобразование. Для своей задачи возьмем оконное БПФ, т.к. расчет БИХ фильтров довольно сложная задача, а КИХ фильтры по вычислительной сложности не очень эффективны. (Честно говоря, изначально я сделал реализацию на БИХ фильтрах Баттерворта 2-го порядка, но меня не устраивало качество и нагрузка на процессор). С БПФ получается все довольно просто. Раскладываем речевой сигнал на гармоники где каждый элемент вектора представляет информацию об определенной частоте (получается что-то вроде большого количества полосовых фильтров). Также раскладываем несущий сигнал и выполняем модуляцию. После всего делаем обратное преобразование и получаем нужный сигнал. Получается что БПФ делает сразу 2 задачи - это раскладывает сигнал на полосы частот (см. схему) и выполняет микширование сигнала после ОБПФ. Для нашей задачи сделаем регулировку количества частотных полос, это позволит настроить нужную окраску тембра. Для БПФ и его обвязки напишем класс clsTrickFFT:

    ' clsTrickFFT - класс для быстрого преобразования Фурье
    ' © Кривоус Анатолий Анатольевич (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

    ' // Тип окна
    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

    ' // Задает размер FFT
    Public Property Let FFTSize(ByVal Value As Long)
    Dim log2 As Double

    log2 = Log(Value) / Log(2)
    ' Число должно быть степенью 2-ки
    If log2 <> Fix(log2) Then
    err.Raise 5
    Exit Property
    End If
    ' Проверяем выход за пределы
    If log2 < 2 Or log2 > 16384 Then
    err.Raise 9
    Exit Property
    End If

    InitWindow mType

    mLog = log2
    mFFTSize = Value

    End Property

    ' // Применить оконную функцию
    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

    ' // Конвертировать 16-битные отсчеты в нормализованные комплексные значения
    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

    ' // Конвертировать комплексные отсчеты, представляющие реальный сигнал в 16-битные реальные
    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

    ' // Выполняет зеркалирование
    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

    ' // Быстрое преобразование Фурье
    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

    ' // Инициализация окна
    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

    ' // Инициализация поворотных множителей для FFT и размера по умолчанию
    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

    Само преобразование выполняет метод FFT; для обратного преобразования вторым параметром передается True. В качестве комплексных чисел будем использовать массив вида arr(1, x), где x - количество комплексных, чисел arr(0, x) - реальная часть, arr(1, x) - мнимая часть. Подробно останавливаться на ПФ я не буду, т.к. это очень большая тема, и кому интересно в сети есть много статей где доступным языком объясняется его смысл и свойства; рассмотрим только основные моменты. Для преобразования нужно исходный действительный сигнал загнать в массив комплексных чисел, обнуляя мнимую часть (по правде говоря исходя из свойств ПФ можно еще ускорить если записать в реальную часть одну часть а в мнимую другую, но я не стал так усложнять). После преобразования получим набор комплексных коэффициентов где реальной части соответствуют коэффициенты перед косинусом, а в мнимой перед синусом. Если представить это на комплексной плоскости, то каждый коэффициент представляет собой вектор, длина которого характеризует амплитуду сигнала на этой частоте, а угол - фазу:
    [​IMG]
    Также имеет место зеркальный эффект (муар)- зеркальное отображение коэффициентов относительно половины частоты дискретизации, который равен по амплитуде и противоположен по фазе. Это происходит из-за дискретизации сигнала, т.к. частоты могут корректно представлены только до половины частоты дискретизации при увеличении частоты происходит алиасинг:
    [​IMG]
    Как видно красная синусоида изначально имеет частоту равную 2 периодам дискретизации, и постепенно период дискретизации увеличивается, частота дискретизированного сигнала уменьшается и в итоге при частоте дискретизации равной частоте синусоиды частота сигнала становится равной 0 герц. Из-за этого коэффициенты Фурье зеркально отображены относительно половины частоты дискретизации. Поэтому при работе со спектром можно обрабатывать только половину спектра, перед ОБПФ нужно просто зеркально скопировать вторую половину массива только сделать комплексное сопряжение (дополнительно мнимые коэффициенты умножить на -1). Для этого предусмотрен метод MakeMirror. При модуляции сигнала у нас будут возникать фазовые искажения, т.к. делая преобразование на каком либо участке сигнала, мы принимаем этот участок за 1 период, который повторяется по обе стороны окна бесконечно долго. И если мы вносим какие-либо изменения в спектр, то наши сигналы могут не совпадать на краях окна и будут возникать разрывы (в нашем случае щелчки). Для предотвращения этого мы умножим сигнал на весовое окно, которое плавно к краям уменьшает амплитуду сигнала, а сами блоки возьмем с перекрытием. Т.к. нам не нужно высокое качество звука, то мы не будем использовать весовые окна до преобразования (хотя следовало бы так сделать, т.к. имеет место размазывание частот), а вычислим в "лоб" с сырым сигналом, преобразуем, выполним ОБПФ и только для результата применим оконную функцию. Также это позволит брать блоки с перекрытием в 50% что на слух приемлемо и достаточно быстро. Чтобы было понятно вот наглядно пример:
    [​IMG]
    Как видно мы берем исходный сигнал 2 раза со сдвигом, захватывая вторую половину во втором проходе. После манипуляций мы микшируем эти два сигнала в месте перекрытия и выдаем на выход первую часть, половина второй части будет позже микшироваться со следующими частями. В качестве окна мы будем использовать окно Ханна. Сам метод называетсяApplyWindow. Исходник класса прокомментирован, поэтому я не буду подробно останавливаться на нем.
    Как было сказано выше для работы FFT нам нужно брать данные с перекрытием и отправлять данные на выход с перекрытием. Для этого мы напишем специальный класс (clsTrickOverlappedBuffer), который будет выдавать нам данные с учетом перекрытия:

    ' clsTrickOverlappedBuffer - класс перекрывающегося буфера
    ' © Кривоус Анатолий Анатольевич (The trick), 2014

    Option Explicit

    Private iBuffer() As Single ' Буфер входных значений
    Private oBuffer() As Single ' Буфер выходных значений
    Private mInit As Boolean ' Инициализирован ли объект
    Private miWritePtr As Long ' Индекс текущей позиции записи во входном буфере
    Private moWritePtr As Long ' Индекс текущей позиции записи в выходном буфере
    Private mWndSize As Long ' Размер порции данных для ввода/вывода
    Private mOverlap As Long ' Размер перекрывания в семплах
    Private iPtr As Long ' Текущая позиция чтения во входном буфере
    Private oPtr As Long ' Текущая позиция чтения в выходном буфере
    Private sampleSize As Long ' Размер выборки в байтах

    ' // Инициализация
    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

    ' Выделяем буфер в 2 раза большего размера для минимального перекрытия 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

    ' // Записать фрейм во входной буфер
    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

    ' // Записать фрейм в выходной буфер
    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
    ' Сначала микшируем перекрывающиеся данные
    ' Проверяем количество семплов до конца буфера
    sampleCount = mWndSize * 2 - pointer
    ' Если недостаточно семплов до конца буфера, то копируем до конца
    If sampleCount > mOverlap Then sampleCount = mOverlap
    ' Микшируем
    For inSample = 0 To sampleCount - 1

    oBuffer(0, pointer) = oBuffer(0, pointer) + data(0, inSample)
    pointer = pointer + 1

    Next
    ' Если не все скопировали, то продолжаем сначала
    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

    ' Теперь копируем неперекрывающуюся часть
    sampleCount = mWndSize * 2 - pointer
    rest = mWndSize - mOverlap
    ' Корректируем с учетом выхода за пределы
    If sampleCount > rest Then sampleCount = rest
    ' Копируем
    If sampleCount Then memcpy oBuffer(0, pointer), data(0, inSample), sampleCount * sampleSize
    ' Если был перенос, то копируем в начало
    If sampleCount < rest Then

    pointer = 0
    memcpy oBuffer(0, pointer), data(0, inSample), (rest - sampleCount) * sampleSize

    End If

    WriteOutputData = True

    End Function

    ' // Получить данные входного буфера
    Public Function GetInputBuffer(data() As Single) As Boolean
    Dim sampleCount As Long
    ' Получаем доступное количество семплов до конца буфера
    sampleCount = mWndSize * 2 - iPtr
    ' Корректируем
    If sampleCount > mWndSize Then sampleCount = mWndSize
    ' Копируем
    If sampleCount > 0 Then
    memcpy data(0, 0), iBuffer(0, iPtr), sampleCount * sampleSize
    End If
    ' При необходимости копируем с начала буфера
    If sampleCount < mWndSize Then
    memcpy data(0, sampleCount), iBuffer(0, 0), (mWndSize - sampleCount) * sampleSize
    End If
    ' Обновляем позицию
    iPtr = (iPtr + mOverlap) Mod mWndSize * 2

    GetInputBuffer = True

    End Function

    ' // Получить данные выходного буфера
    Public Function GetOutputBuffer(data() As Single) As Boolean
    Dim sampleCount As Long
    ' Получаем доступное количество семплов до конца буфера
    sampleCount = mWndSize * 2 - oPtr
    ' Корректируем
    If sampleCount > mWndSize Then sampleCount = mWndSize
    ' Копируем
    If sampleCount > 0 Then
    memcpy data(0, 0), oBuffer(0, oPtr), sampleCount * sampleSize
    oPtr = oPtr + sampleCount
    End If
    ' При необходимости копируем с начала буфера
    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 инициализирует внутренние буферы хранения данных. Метод WriteInputData записывает во внутренний буфер данные входного сигнала. С помощью этого метода мы будем записывать захваченный сигнал и несущий сигнал. Метод WriteOutputData микширует переданные данные во внутреннем буфере с прошлыми данными добавленными в предыдущем вызове этого метода. Этот метод мы будем использовать для обработанных данных и писать уже промодулированный сигнал с помощью этого метода. GetInputBuffer и GetOutputBufferзаполняют входной буфер данными с учетом перекрытия. GetInputBuffer получает данные записанные методом WriteInputData, соответственно метод GetOutputBuffer получает данные записанные методом WriteOutputData.
    Теперь рассмотрим сам модулятор представленный классом clsTrickModulator, который занимается непосредственно преобразованием спектра:

    ' clsTrickModulator - класс модулятора
    ' © Кривоус Анатолий Анатольевич (The trick), 2014

    Option Explicit

    Private mBands As Long ' Количество полос
    Private mDryWet As Single ' Баланс исходного и обработанного звука
    Private mVolume As Single ' Громкость
    Private mLevels() As Single ' АЧХ

    ' // Громкость
    Public Property Let Volume(ByVal Value As Single)
    mVolume = Value
    End Property
    Public Property Get Volume() As Single
    Volume = mVolume
    End Property

    ' // АЧХ
    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

    ' // Баланс
    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

    ' // Количество полос
    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

    ' // Функция выполняет обработку
    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)
    ' Зеркальную сторону не вычисляем
    nCount = FFTSize 2
    ' Получаем число отсчетов на полосу
    samplePerBand = nCount mBands
    ' Вычисляем величину усиления
    ampValue = (Sqr(mBands) * invDryWet) / 2.5 + mDryWet
    ' Проходим по полосам
    For band = 0 To mBands - 1
    ' Проверяем выход за пределы
    endBand = band * samplePerBand + samplePerBand
    If endBand >= nCount Then endBand = nCount - 1
    ' Обнуляем величину спектральной составляющей для текущей полосы
    modValue = 0
    ' Проходим по отсчетам спектра текущей полосы
    For sample = band * samplePerBand To endBand
    ' Вычисляем величину спекта для всех отсчетов полосы
    modValue = modValue + Sqr(modulation(0, sample) * modulation(0, sample) + _
    modulation(1, sample) * modulation(1, sample))
    Next
    ' Модулируем в текущей полосе
    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

    Класс имеет свойство Volume, которое определяет уровень выходной громкости. Свойство Bands определяет количество полос на которые будет делится спектр при модуляции. К примеру при частоте дискретизации 44100 Гц. и размере БПФ равным 2048, получим разрешение по частоте равное 44100 / 2048 ≈ 21.53 Гц. При количестве частотных полос равной 64 будем брать по 2048 / 2 / 64 = 16 отсчетов (344.48 Гц) частоты, для каждой модуляции. Свойство DryWet определяет баланс между оригинальным сигналом и преобразованным на выходе модулятора. Метод SetLevels задает массив с коэффициентами амплитудно-частотной характеристики (АЧХ) на которую умножается сигнал. Это позволит производить эквализацию сигнала и улучшить качество звука после обработки. Самый главный метод - Process, который собственно и производит обработку; разберем его подробней. Сначала мы вычисляем количество отсчетов на одну полосу исходя из свойства Bands, потом вычисляем коэффициент усиления выходного сигнала в зависимости от количества частотных полос - эта формула получена экспериментально. Дальше мы проходим по частотным полосам речевого (modulation) сигнала и в коэффициентах соответствующих каждой полосе вычисляем энергию данных частот. Ранее я писал что амплитуда спектральной составляющей - это длина вектора, поэтому мы просто суммируем длины векторов соответствующих частот, это и будет энергия в данном диапазоне частот. Далее мы проходим уже по несущему сигналу в тех же спектральных отсчетах изменяем уровень сигнала в соответствии с вычисленной энергией, также сразу вычисляем выходной уровень, применяем эквализацию. При умножении двух компонент вектора (комплексного числа) на величину энергии происходит его масштабирование. Всеми этими манипуляциями мы модулируем несущий сигнал, речевым, что нам и требовалось.
    Итак, все компоненты готовы. Теперь нужно все собрать и проверять работу. Для пользовательского интерфейса я разработал несколько контролов специально для вокодера. Описывать принцип работы и разработку каждого я не буду, т.к. это займет много времени, а расскажу вкратце о каждом из них. ctlTrickKnob - контрол регулятор, что-то вроде обычного потенциометра. С ним все понятно это обычный регулятор, подобие того же виндового Slider'а, только с круговой регулировкой. ctlTrickCommand - это обычная кнопка с поддержкой иконки и добавлена только для внешнего вида. ctlTrickEqualizer - самый интересный контрол. Он позволяет корректировать АЧХ сигнала. Его панель имеет логарифмическую шкалу, как по частотам, так и по уровням, что позволяет более естественно для слуха изменять параметры. Для добавления точки на АЧХ нужно нажать левой кнопкой в пустом месте, для удаления - правой. При изменении АЧХ контрол генерирует событие Change. Все контролы предназначены только для вокодера, поэтому их функционал минимален.
    Теперь все "закидываем" на форму, и пишем код:

    ' frmTrickVocoder - главная форма TrickVocoder
    ' © Кривоус Анатолий Анатольевич (The trick), 2014

    Option Explicit

    Dim WithEvents AudioCapture As clsTrickSound ' Объект захвата звука
    Dim WithEvents AudioPlayback As clsTrickSound ' Объект записи звука

    Private inpBuffer() As Integer ' Буфер захвата звука
    Private outBuffer() As Integer ' Буфер воспроизведения звука
    #1084;Private rawBuffer() As Integer ' Буфер сырых данных исходного Wave-файла
    Private plyBuffer As clsTrickOverlappedBuffer ' Буфер перекрывающихся данных несущей
    Private capBuffer As clsTrickOverlappedBuffer ' Буфер перекрывающихся данных модулятора
    Private FFT As clsTrickFFT ' Объект для работы с FFT и преобразованием буфера звука
    Private Modulator As clsTrickModulator ' Модулятор
    Private mFFTSize As Long ' Размер FFT
    Private mOverlap As Long ' Количество перекрытий
    Private mRawSize As Long ' Размер сырых данных буфера в семплах
    Private mInpFile As String ' Имя файла, если захват из файла
    Private tmpCapBuf() As Single ' Временный буфер захвата
    Private tmpPlyBuf() As Single ' Временный буфер воспроизведения
    Private wavConv As clsTrickWavConverter ' Объект-конвертер сигнала носителя
    Private inpConv As clsTrickWavConverter ' Объект-конвертер модулирующего сигнала

    ' // Получить объект захвата
    Public Property Get AudioCaptureDevice() As clsTrickSound
    Set AudioCaptureDevice = AudioCapture
    End Property

    ' // Получить имя файла захвата
    Public Property Get InputFileName() As String
    InputFileName = mInpFile
    End Property

    ' // Закрыть окно
    Private Sub btnClose_Click()
    Unload Me
    End Sub

    ' // Открыть файл несущего сигнала
    Private Sub btnOpenCarrier_Click()
    Dim FileName As String
    Dim conv As clsTrickWavConverter
    ' Получаем имя файла
    FileName = GetFile(Me.hwnd)

    If Len(FileName) Then

    Set conv = New clsTrickWavConverter
    ' При успешном чтении устанавливаем его в качестве текущего
    If conv.ReadWaveFile(FileName) Then
    Set wavConv = conv
    End If

    End If

    End Sub

    ' // Настройки
    Private Sub btnSettings_Click()
    Dim frm As frmSettings
    Dim cur As Long

    Set frm = New frmSettings

    frm.Show vbModal
    ' При нажатии ОК
    If frm.Result = vbOK Then
    ' Получаем текущее устройство захвата
    cur = AudioCapture.CurrentCaptureDeviceID()
    ' Очищаем буфер, т.к. если дальше будет неудача то мы будем слышать зацикленный текущий сигнал
    memset inpBuffer(0), mFFTSize * 2, 0

    If frm.SelectedDevice >= AudioCapture.CaptureDevices.count Then
    ' Захват из файла
    Set inpConv = Nothing
    Set inpConv = New clsTrickWavConverter
    ' Читаем файл
    If Not inpConv.ReadWaveFile(frm.FileName) Then
    ' Восстанавливаем назад
    InitCapture cur

    Else

    mInpFile = frm.FileName
    AudioCapture.StopProcess

    End If

    Else
    ' Захват с устройства
    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 "Ошибка"
    End If

    End If

    End If

    End Sub

    ' // Изменение АЧХ
    Private Sub equResponse_Change()
    Dim data() As Single

    ReDim data(mFFTSize 2 - 1)
    ' Получаем из контрола
    equResponse.GetCurve data()
    ' Задаем модулятору
    Modulator.SetLevels data()

    End Sub

    ' // Загрузка формы
    Private Sub Form_Load()
    ' Размер FFT
    mFFTSize = 2048
    ' Перекрытие
    mOverlap = 2
    ' Инициализация воспроизведения
    If Not InitPlayback() Then Unload Me
    ' Инициализация захвата
    If Not InitCapture() Then
    Call btnSettings_Click
    Else
    AudioCapture.StartProcess
    End If

    Set plyBuffer = New clsTrickOverlappedBuffer
    Set capBuffer = New clsTrickOverlappedBuffer
    ' Установка перекрывающихся буферов
    plyBuffer.Init mFFTSize, mFFTSize mOverlap
    capBuffer.Init mFFTSize, mFFTSize mOverlap

    Set FFT = New clsTrickFFT
    ' Установка размера БПФ и окна
    FFT.FFTSize = mFFTSize
    FFT.WindowType = WT_HANN

    Set Modulator = New clsTrickModulator
    ' Создание буферов
    ReDim tmpCapBuf(1, mFFTSize - 1)
    ReDim tmpPlyBuf(1, mFFTSize - 1)
    ReDim inpBuffer(mFFTSize - 1)
    ReDim outBuffer(mFFTSize - 1)
    ' Обновление информации
    Call equResponse_Change
    Call knbBands_Change
    Call knbMix_Change
    Call knbVolume_Change
    Call knbPitch_Change
    ' Запуск воспроизведения
    AudioPlayback.StartProcess

    Dim hRgn As Long
    ' Задаем регион окну
    hRgn = CreateRoundRectRgn(0, 0, Me.ScaleWidth, Me.ScaleHeight, 2, 2)
    SetWindowRgn Me.hwnd, hRgn, False
    ' Задаем иконку
    SetIcon Me.hwnd
    End Sub

    ' // Получены новые данные с устройства захвата
    Private Sub AudioCapture_NewData(ByVal DataPtr As Long, ByVal CountBytes As Long)
    ' Копируем во временный буфер
    memcpy inpBuffer(0), ByVal DataPtr, CountBytes
    End Sub

    ' // Нужны новые данные для воспроизведения
    Private Sub AudioPlayback_NewData(ByVal DataPtr As Long, ByVal CountBytes As Long)
    ' Обработка прошлых данных
    Call Process
    ' Копируем
    memcpy ByVal DataPtr, outBuffer(0), CountBytes
    End Sub

    ' // Процесс
    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
    ' Захват из файла
    inpConv.Convert VarPtr(inpBuffer(0)), mFFTSize * 2, ret
    ' Если данные закончились, то начинаем сначала
    If ret < mFFTSize * 2 Then
    inpConv.InputCurrentPosition = 0
    inpConv.Convert VarPtr(inpBuffer(ret 2)), mFFTSize * 2 - ret, ret
    End If

    End If
    ' Если не задан несущий сигнал
    If wavConv Is Nothing Then
    ' Копируем даные захвата в выходной буфер и выходим
    outBuffer = inpBuffer
    Exit Sub

    End If
    ' Преобразовываем данные в комплексный формат
    FFT.Convert16BitToComplex inpBuffer(), tmpCapBuf()
    ' Пишем данные в перекрывающийся буфер
    capBuffer.WriteInputData tmpCapBuf()
    ' Получаем размер (в семплах) несущего сигнала
    datSize = wavConv.Rate * wavConv.InputDataSize 2

    If datSize < mRawSize Then
    ' Семпл слишком короткий
    wavConv.Convert VarPtr(rawBuffer(0)), mRawSize * 2, ret
    ' Семпл целиком не поместился, начинаем сначала
    If ret * 2 <> datSize Then

    wavConv.InputCurrentPosition = 0
    wavConv.Convert VarPtr(rawBuffer(ret 2)), datSize * 2 - ret, ret

    End If
    ' Зацикливаем его на всю длину буфера
    ret = datSize
    idx = 0

    Do While ret < mRawSize

    rawBuffer(ret) = rawBuffer(idx)
    ret = ret + 1
    idx = idx + 1

    Loop
    ' Обновляем позицию
    wavConv.InputCurrentPosition = ((wavConv.InputCurrentPosition + idx) Mod datSize)

    Else
    ' Семпл достаточно длиный
    wavConv.Convert VarPtr(rawBuffer(0)), mRawSize * 2, ret
    ' Если данные закончились, то начинаем сначала
    If ret < mRawSize * 2 Then

    wavConv.InputCurrentPosition = 0
    wavConv.Convert VarPtr(rawBuffer(ret 2)), mRawSize * 2 - ret, ret
    End If

    End If

    ' Сжимаем/растягиваем массив с учетом сдвига тона
    delta = 2 ^ (knbPitch.Value / 12)
    For idx = 0 To mFFTSize - 1
    outBuffer(idx) = rawBuffer(Fix(idx * delta))
    Next
    ' Конвертируем данные несущего сигнала в комплексную форму
    FFT.Convert16BitToComplex outBuffer(), tmpPlyBuf()
    ' Пишем данные в перекрывающийся буфер
    plyBuffer.WriteInputData tmpPlyBuf()

    ' Проходы по перекрытиям
    For ovrLap = 0 To mOverlap - 1

    ' Получаем очередные буфера
    capBuffer.GetInputBuffer tmpCapBuf()
    plyBuffer.GetInputBuffer tmpPlyBuf()
    ' Быстрое преобразование Фурье
    FFT.FFT tmpCapBuf(), False
    FFT.FFT tmpPlyBuf(), False
    ' Модуляция
    Modulator.Process tmpPlyBuf(), tmpCapBuf()
    ' Зеркалирование
    FFT.MakeMirror tmpPlyBuf()
    ' Обратное преобразование Фурье
    FFT.FFT tmpPlyBuf(), True
    ' Окно
    FFT.ApplyWindow tmpPlyBuf()
    ' Запись в выход
    plyBuffer.WriteOutputData tmpPlyBuf()

    Next

    ' Получаем данные
    plyBuffer.GetOutputBuffer tmpPlyBuf()
    ' Преобразуем
    FFT.ConvertComplexTo16Bit tmpPlyBuf(), outBuffer()

    End Sub

    ' // Инициализация захвата звука
    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

    ' // Инициализация проигрывания звука
    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

    ' // Нажатие мыши в окне
    Private Sub Form_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
    Dim pos As Currency

    If y <= 26 Then
    ' Если мышь нажата в пределах заголовка, то включаем перетаскивание
    ReleaseCapture
    GetCursorPos pos
    SendMessage Me.hwnd, WM_NCLBUTTONDOWN, HTCAPTION, pos

    End If

    End Sub

    ' // Изменение количества полос
    Private Sub knbBands_Change()

    Modulator.Bands = knbBands.Value
    knbBands.Caption = knbBands.Value

    End Sub

    ' // Изменение смешивания
    Private Sub knbMix_Change()
    Dim lg As Single
    ' Логарифмический масштаб
    lg = ((10 ^ (knbMix.Value / 50)) - 1) / 99
    Modulator.DryWet = lg
    knbMix.Caption = Format(lg, "#0.00%")

    End Sub

    ' // Изменение тона несущей
    Private Sub knbPitch_Change()

    mRawSize = -Int(-mFFTSize * (2 ^ (knbPitch.Value / 12)))
    ReDim rawBuffer(mRawSize - 1)

    knbPitch.Caption = Format(knbPitch.Value, "0 sem;-0 sem;none")

    End Sub

    ' // Изменение громкости
    Private Sub knbVolume_Change()
    Dim lg As Single
    ' Логарифмический масштаб
    lg = ((10 ^ (knbVolume.Value / 50)) - 1) / 99
    Modulator.Volume = lg
    knbVolume.Caption = Format(lg, "#0.00%")

    End Sub


    При загрузке формы мы выполняем инициализацию всех компонентов. Захват, воспроизведение звука, размер FFT, величину перекрытия, перекрывающиеся буферы, создание буферов для целочисленных и комплексных данных. Далее я сделал форму окна со скругленными углами, т.к. использую окно без рамки (рисовать в неклиентской области не было желания). Теперь вся задача сводится к обработке событий AudioPlayback_NewData и AudioCapture_NewData. Первое событие возникает когда устройство воспроизведения нуждается в очередной порции звуковых данных, второе при заполнении буфера захвата, в котором мы просто копируем данные во временный буфер откуда потом возьмем их при обработкеAudioPlayback_NewData. Самый главный метод - Process, в нем мы непосредственно делаем преобразование. Сначала мы проверяем идет ли у нас захват из файла или устройства. Для этого мы проверяем переменную mInpFile, которая определяет имя входного файла для захвата. Если захват производится из файла, то мы с помощью объекта inpConv, который является экземпляром класса clsTrickWavConverter, конвертируем данные в нужный нам формат. Если данные закончились (число прочитанных байт не соответствует переданному), то значит мы находимся на границе файла и для продолжения нужно начать сначала. Также проверяем несущий сигнал и если он не задан то просто копируем входные данные на выход и выходим, в этом случае мы будем слышать необработанный звук. В противном случае мы переводим данные в комплексный вид (заносим в реальную часть сигнал, а мнимую обнуляем) и заносим полученный массив в перекрывающийся буфер. Далее начинаем обработку несущего сигнала. Т.к. несущий сигнал у нас может быть очень маленькой длины (можно использовать один период волны), то в целях оптимизации я сделаем сами повторение сигнала если это потребуется. Поясню. Например если у нас несущий сигнал длительностью 10 мс, а буфер 100 мс (к примеру), то можно было бы просто каждый раз вызывать конвертацию с помощью ACM переписывая указатель в массиве назначения, но это будет неоптимально. Для оптимизации можно конвертировать только один раз, а потом просто продублировать данные до конца массива, что мы и сделаем. Только потом не забыть изменить позицию в исходном файле, иначе при следующем чтении фазы не будут совпадать и будут щелчки. Писать мы будем в другой буфер (rawBuffer). Этот буфер имеет длину исходя из сдвига тона. Например если мы хотим сдвинуть тон на величину semitones (полутонов), то размер буфера rawBuffer должен быть в 2[sup]semitones/12[/sup] раза больше. Далее мы просто сожмем/растянем буфер до величины mFFTSize, что даст нам ускорение/замедление и как следствие повышение/понижение тона. После всех манипуляций мы пишем данные в перекрывающийся буфер и начинаем обработку. Для этого проходим по количеству перекрытий и обрабатываем данные. Объекты класса clsTrickOverlappedBuffer вернут нам правильные данные. Обработка понятна из кода, т.к. мы подробно разбирали работу каждого класса. После обработки всех перекрытий мы получаем выходные данные и конвертируем их в целочисленные, пригодные для воспроизведения.
    В качестве настройки используется форма frmSettings. В качестве списка устройств используется стандартный листбокс, только отрисовка идет через Please login or register to view links. В список устройства добавляются в следующем порядке:

    • Устройство по умолчанию для заданного формата
    • Устройство 1
    • Устройство 2
    • ...
    • Устройство n
    • Захват из файла

    Для отработки клика по последнему пункту используется сообщение LB_GETITEMRECT, которое получает координаты и размер пункта в списке. Если этого не сделать то клик за пределами листа, если внизу есть пустое пространство будет равносилен клику на последнем пункте. В обработчике кнопки настроек в главной формы frmTrickVocoder мы проверяем устройство захвата и либо открываем файл для конвертации либо инициализируем захват. Для регулировки громкости и подмешивания используем логарифмическую шкалу, т.к. чувствительность человеческого слуха нелинейна. Вот в принципе и все. Спасибо за внимание.

    [​IMG]
     
    • Like Like x 1
    Последнее редактирование модератором: 2 сен 2015
    Метки:
  2. ponchic

    ponchic юзверь

    Регистрация:
    15 дек 2013
    Сообщения:
    407
    Симпатии:
    276
    Есть ввкод [ code ] && [ spoiler ] (Без пробелов)
     

Поделиться этой страницей

Загрузка...