На главную Наши проекты:
Журнал   ·   Discuz!ML   ·   Wiki   ·   DRKB   ·   Помощь проекту
ПРАВИЛА FAQ Помощь Участники Календарь Избранное RSS
msm.ru
! Правила раздела Visual Basic: Общие вопросы
Здесь обсуждаются вопросы по языку Visual Basic 1-6 (а так же по схожим языкам, как, например, PowerBASIC).
Вопросы по Visual Basic .NET (это который входит в состав Visual Studio 2002/2003/2005/2008+, для тех, кто не в курсе) обсуждаются в разделе .NET.

Обратите внимание:
1. Прежде чем начать новую тему или отправить сообщение, убедитесь, что Вы не нарушаете правил форума!
2. Обязательно воспользуйтесь поиском. Возможно, Ваш вопрос уже обсуждали. Полезные ссылки приведены ниже.
3. Темы с просьбой выполнить какую-либо работу за автора в этом разделе не обсуждаются. Студенты, вам сюда: ПОМОЩЬ СТУДЕНТАМ!
4. Используйте теги [ code=vba ] ...текст программы... [ /code ] для выделения текста программы подсветкой.
5. Помните, здесь телепатов нет. Формулируйте свой вопрос максимально грамотно и чётко: Как правильно задавать вопросы
6. Запрещено отвечать в темы месячной (и более) давности, без веских на то причин.

Полезные ссылки:
user posted image FAQ Сайта user posted image FAQ Раздела user posted image Кладовка user posted image Наши Исходники user posted image API-Guide user posted image Поиск по Разделу user posted image MSDN Library Online user posted image Google

Ваше мнение о модераторах: user posted image SCINER, user posted image B.V.
Модераторы: SCINER, B.V.
  
> Вокодер на VB6. , Создание простого FFT вокодера на VB6.
    https://www.youtube.com/watch?v=KCXZpd-pEkg

    Всем привет. Создавая музыку, я видел много разных виртуальных инструментов и эффектов. Одним из интереснейших эффектов является вокодер, который позволяет промодулировать голос и сделать его например похожим на голос робота или что-то в этом духе. Вокодер изначально использовался для сжатия речевой информации, а после его начали применять в музыкальной сфере. Т.к. у меня появилось свободное время, я решил написать что-то подобное ради эксперимента и подробно описать этапы разработки на VB6.
    Итак, взглянем на простейшую схему вокодера:
    user posted image
    Сигнал с микрофона (речь), подается на банк полосовых фильтров, каждый из которых пропускает только небольшую часть диапазона частот речевого сигнала. Чем больше количество фильтров - тем лучше разборчивость речи. В тоже время несущий сигнал (например пилообразный) также пропускается через аналогичный банк фильтров. С выходов фильтров речевого сигнала сигнал поступает на детекторы огибающей которые управляют модуляторами, а с выходов фильтров несущей сигнал поступает на другие входы модуляторов. В итоге каждая полоса речевого сигнала регулирует уровень соответствующей полосы несущей (модулирует ее). После сигнал выходной сигнал со всех модуляторов смешивается и попадает на выход. Для повышения разборчивости речи также применяют дополнительные блоки, вроде детектора "шипящих" звуков. Итак, чтобы начать разработку нужно определиться с исходными сигналами, откуда их будем брать. Можно к примеру захватить данные из файла или напрямую обрабатывать в реальном времени с микрофонного или линейного входа. Для тестирования очень удобно пользоваться файлом, поэтому мы сделаем и так и так. В качестве несущей будем использовать внешний файл зацикленный по кругу, для регулировки тональности просто добавим возможность изменения скорости воспроизведения, что позволит менять тональность. Для захвата звука из файла будем использовать Audio Compression Manager (ACM), с ним очень удобно производить конвертирование между форматами (т.к. файл может быть любого формата, то пришлось бы писать несколько функций для разных форматов). Может так оказаться что для конвертирования в нужный формат не окажется нужного ACM драйвера, тогда воспроизведение этого файла будет недоступным (хотя можно это попробовать сделать в 2 этапа). В качестве входных файлов будем использовать wav - файлы, т.к. для работы с ними в системе есть специальные функции облегчающие получение данных из них. Вот сам исходный код класса clsTrickWavConverter:
    ExpandedWrap disabled
      ' 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 представляет собой файл в формате RIFF, который в свою очередь состоит из блоков, называемых чанками (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:
    ExpandedWrap disabled
      ' 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, 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
       
      ' // Приостановить воспроизведение
      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:
      ExpandedWrap disabled
        ' 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) - мнимая часть. Подробно останавливаться на ПФ я не буду, т.к. это очень большая тема, и кому интересно в сети есть много статей где доступным языком объясняется его смысл и свойства; рассмотрим только основные моменты. Для преобразования нужно исходный действительный сигнал загнать в массив комплексных чисел, обнуляя мнимую часть (по правде говоря исходя из свойств ПФ можно еще ускорить если записать в реальную часть одну часть а в мнимую другую, но я не стал так усложнять). После преобразования получим набор комплексных коэффициентов где реальной части соответствуют коэффициенты перед косинусом, а в мнимой перед синусом. Если представить это на комплексной плоскости, то каждый коэффициент представляет собой вектор, длина которого характеризует амплитуду сигнала на этой частоте, а угол - фазу:
      user posted image
      Также имеет место зеркальный эффект (муар)- зеркальное отображение коэффициентов относительно половины частоты дискретизации, который равен по амплитуде и противоположен по фазе. Это происходит из-за дискретизации сигнала, т.к. частоты могут корректно представлены только до половины частоты дискретизации при увеличении частоты происходит алиасинг:
      user posted image
      Как видно красная синусоида изначально имеет частоту равную 2 периодам дискретизации, и постепенно период дискретизации увеличивается, частота дискретизированного сигнала уменьшается и в итоге при частоте дискретизации равной частоте синусоиды частота сигнала становится равной 0 герц. Из-за этого коэффициенты Фурье зеркально отображены относительно половины частоты дискретизации. Поэтому при работе со спектром можно обрабатывать только половину спектра, перед ОБПФ нужно просто зеркально скопировать вторую половину массива только сделать комплексное сопряжение (дополнительно мнимые коэффициенты умножить на -1). Для этого предусмотрен метод MakeMirror. При модуляции сигнала у нас будут возникать фазовые искажения, т.к. делая преобразование на каком либо участке сигнала, мы принимаем этот участок за 1 период, который повторяется по обе стороны окна бесконечно долго. И если мы вносим какие-либо изменения в спектр, то наши сигналы могут не совпадать на краях окна и будут возникать разрывы (в нашем случае щелчки). Для предотвращения этого мы умножим сигнал на весовое окно, которое плавно к краям уменьшает амплитуду сигнала, а сами блоки возьмем с перекрытием. Т.к. нам не нужно высокое качество звука, то мы не будем использовать весовые окна до преобразования (хотя следовало бы так сделать, т.к. имеет место размазывание частот), а вычислим в "лоб" с сырым сигналом, преобразуем, выполним ОБПФ и только для результата применим оконную функцию. Также это позволит брать блоки с перекрытием в 50% что на слух приемлемо и достаточно быстро. Чтобы было понятно вот наглядно пример:
      user posted image
      Как видно мы берем исходный сигнал 2 раза со сдвигом, захватывая вторую половину во втором проходе. После манипуляций мы микшируем эти два сигнала в месте перекрытия и выдаем на выход первую часть, половина второй части будет позже микшироваться со следующими частями. В качестве окна мы будем использовать окно Ханна. Сам метод называется ApplyWindow. Исходник класса прокомментирован, поэтому я не буду подробно останавливаться на нем.
      Как было сказано выше для работы FFT нам нужно брать данные с перекрытием и отправлять данные на выход с перекрытием. Для этого мы напишем специальный класс (clsTrickOverlappedBuffer), который будет выдавать нам данные с учетом перекрытия:
      ExpandedWrap disabled
        ' 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, который занимается непосредственно преобразованием спектра:
      ExpandedWrap disabled
        ' 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. Все контролы предназначены только для вокодера, поэтому их функционал минимален.
      Теперь все "закидываем" на форму, и пишем код:
      ExpandedWrap disabled
        ' 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                      ' Буфер воспроизведения звука
        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;non\e")
            
        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 должен быть в 2semitones/12 раза больше. Далее мы просто сожмем/растянем буфер до величины mFFTSize, что даст нам ускорение/замедление и как следствие повышение/понижение тона. После всех манипуляций мы пишем данные в перекрывающийся буфер и начинаем обработку. Для этого проходим по количеству перекрытий и обрабатываем данные. Объекты класса clsTrickOverlappedBuffer вернут нам правильные данные. Обработка понятна из кода, т.к. мы подробно разбирали работу каждого класса. После обработки всех перекрытий мы получаем выходные данные и конвертируем их в целочисленные, пригодные для воспроизведения.
      В качестве настройки используется форма frmSettings. В качестве списка устройств используется стандартный листбокс, только отрисовка идет через мой класс. В список устройства добавляются в следующем порядке:
      • Устройство по умолчанию для заданного формата
      • Устройство 1
      • Устройство 2
      • ...
      • Устройство n
      • Захват из файла
      Для отработки клика по последнему пункту используется сообщение LB_GETITEMRECT, которое получает координаты и размер пункта в списке. Если этого не сделать то клик за пределами листа, если внизу есть пустое пространство будет равносилен клику на последнем пункте. В обработчике кнопки настроек в главной формы frmTrickVocoder мы проверяем устройство захвата и либо открываем файл для конвертации либо инициализируем захват. Для регулировки громкости и подмешивания используем логарифмическую шкалу, т.к. чувствительность человеческого слуха нелинейна. Вот в принципе и все. Спасибо за внимание.
      user posted image

      Скачать.
        TheTrik
        Просто бомба!!! Давно я искал нечто подобное! Если получится с временем, попробую на базе этого изобразить WDRC, потом еще чего-нить=) Обязательно тут поделюсь.
        0 пользователей читают эту тему (0 гостей и 0 скрытых пользователей)
        0 пользователей:


        Рейтинг@Mail.ru
        [ Script execution time: 0,0775 ]   [ 17 queries used ]   [ Generated: 28.03.24, 10:53 GMT ]