Вокодер на VB6 часть 1

Автор обещает много интересных штучек.

Модератор: The trick

The trick
Постоялец
Постоялец
 
Сообщения: 722
Зарегистрирован: 26.06.2010 (Сб) 23:08

Вокодер на VB6 часть 1

Сообщение The trick » 01.12.2014 (Пн) 19:28


Всем привет. Создавая музыку, я видел много разных виртуальных инструментов и эффектов. Одним из интереснейших эффектов является вокодер, который позволяет промодулировать голос и сделать его например похожим на голос робота или что-то в этом духе. Вокодер изначально использовался для сжатия речевой информации, а после его начали применять в музыкальной сфере. Т.к. у меня появилось свободное время, я решил написать что-то подобное ради эксперимента и подробно описать этапы разработки на VB6.
Итак, взглянем на простейшую схему вокодера:
Изображение
Сигнал с микрофона (речь), подается на банк полосовых фильтров, каждый из которых пропускает только небольшую часть диапазона частот речевого сигнала. Чем больше количество фильтров - тем лучше разборчивость речи. В тоже время несущий сигнал (например пилообразный) также пропускается через аналогичный банк фильтров. С выходов фильтров речевого сигнала сигнал поступает на детекторы огибающей которые управляют модуляторами, а с выходов фильтров несущей сигнал поступает на другие входы модуляторов. В итоге каждая полоса речевого сигнала регулирует уровень соответствующей полосы несущей (модулирует ее). После сигнал выходной сигнал со всех модуляторов смешивается и попадает на выход. Для повышения разборчивости речи также применяют дополнительные блоки, вроде детектора "шипящих" звуков. Итак, чтобы начать разработку нужно определиться с исходными сигналами, откуда их будем брать. Можно к примеру захватить данные из файла или напрямую обрабатывать в реальном времени с микрофонного или линейного входа. Для тестирования очень удобно пользоваться файлом, поэтому мы сделаем и так и так. В качестве несущей будем использовать внешний файл зацикленный по кругу, для регулировки тональности просто добавим возможность изменения скорости воспроизведения, что позволит менять тональность. Для захвата звука из файла будем использовать Audio Compression Manager (ACM), с ним очень удобно производить конвертирование между форматами (т.к. файл может быть любого формата, то пришлось бы писать несколько функций для разных форматов). Может так оказаться что для конвертирования в нужный формат не окажется нужного ACM драйвера, тогда воспроизведение этого файла будет недоступным (хотя можно это попробовать сделать в 2 этапа). В качестве входных файлов будем использовать wav - файлы, т.к. для работы с ними в системе есть специальные функции облегчающие получение данных из них. Вот сам исходный код класса clsTrickWavConverter:
Код: Выделить всё
' clsTrickWavConverter - класс для конвертации Wav файлов используя ACM
' © Кривоус Анатолий Анатольевич (The trick), 2014

Option Explicit

Private Type WAVEFORMATEX
    wFormatTag      As Integer
    nChannels       As Integer
    nSamplesPerSec  As Long
    nAvgBytesPerSec As Long
    nBlockAlign     As Integer
    wBitsPerSample  As Integer
    cbSize          As Integer
End Type

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

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

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

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

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

Private mInpFmt     As WAVEFORMATEX     ' Входной формат, определяется файлом
Private mOutFmt     As WAVEFORMATEX     ' Выходной формат, определяется пользователем
Private mDataSize   As Long             ' Размер данных в байтах
Private bufIdx      As Long             ' Текущая позиция во входном буфере
Private buffer()    As Byte             ' Буфер
Private hStream     As Long             ' Описатель потока сжатия
Private mInit       As Boolean          ' Инициализирован ли ACM

' // Входной формат
Public Property Get InputNumOfChannels() As Integer
    InputNumOfChannels = mInpFmt.nChannels
End Property
Public Property Get InputSamplesPerSecond() As Integer
    InputSamplesPerSecond = mInpFmt.nSamplesPerSec
End Property
Public Property Get InputBitPerSample() As Integer
    InputBitPerSample = mInpFmt.wBitsPerSample
End Property

' // Размер входных данных
Public Property Get InputDataSize() As Long
    InputDataSize = mDataSize
End Property

' // Текущая позиция в файле в отсчетах
Public Property Get InputCurrentPosition() As Long
    InputCurrentPosition = bufIdx / mInpFmt.nBlockAlign
End Property
Public Property Let InputCurrentPosition(ByVal Value As Long)
    Dim index As Long
   
    index = Value * mInpFmt.nBlockAlign
   
    If index >= mDataSize Or index < 0 Then
       
        err.Raise 5
        Exit Property
       
    End If
   
    bufIdx = index
End Property

' // Выходной формат
Public Property Get OutputNumOfChannels() As Integer
    OutputNumOfChannels = mOutFmt.nChannels
End Property
Public Property Get OutputSamplesPerSecond() As Integer
    OutputSamplesPerSecond = mOutFmt.nSamplesPerSec
End Property
Public Property Get OutputBitPerSample() As Integer
    OutputBitPerSample = mOutFmt.wBitsPerSample
End Property

' // Отношение размеров
Public Property Get Rate() As Single
    Dim outLen  As Long
    ' Проверка на инициализированность
    If Not mInit Then
        If Not Init() Then Exit Property
    End If
    acmStreamSize hStream, mDataSize, outLen, ACM_STREAMSIZEF_SOURCE
    Rate = outLen / mDataSize
End Property

' // Задать формат
Public Function SetFormat(ByVal NumOfChannels As Integer, ByVal SamplesPerSecond As Long, ByVal BitPerSample As Integer) As Boolean
    Dim outFmt  As WAVEFORMATEX
    Dim ret     As Long
    ' Проверяем формат
    With outFmt
        .wFormatTag = 1
        .nChannels = NumOfChannels
        .nSamplesPerSec = SamplesPerSecond
        .wBitsPerSample = BitPerSample
        .nBlockAlign = .wBitsPerSample \ 8 * .nChannels
        .nAvgBytesPerSec = .nSamplesPerSec * .nBlockAlign
    End With
    ' Если открыт файл
    If mDataSize Then
        ' Запрашиваем у менеджера сжатия, может ли он преобразовать этот формат в нужный нам
        ret = acmStreamOpen(ByVal 0&, 0, mInpFmt, outFmt, ByVal 0&, ByVal 0&, ByVal 0&, ACM_STREAMOPENF_QUERY)
        If ret Then Exit Function
        ' Закрываем активный поток
        If hStream Then acmStreamClose hStream, 0
        mInit = False
    End If

    mOutFmt = outFmt
    SetFormat = True
   
End Function

' // Читает Wav файл и проверяет возможность перекодировать в выходной формат
Public Function ReadWaveFile(strFileName As String) As Boolean
    Dim hIn     As Long
    Dim inf     As MMCKINFO
    Dim sInf    As MMCKINFO
    Dim inpFmt  As WAVEFORMATEX
    Dim ret     As Long
    ' Читаем файл
    hIn = mmioOpen(strFileName, ByVal 0, MMIO_READ)
    If (hIn = 0) Then
        MsgBox "Error opening file"
        Exit Function
    End If
    ' Ищем чанк WAVE
    inf.fccType = mmioStringToFOURCC("WAVE", 0)
    If mmioDescend(hIn, inf, ByVal 0, MMIO_FINDRIFF) Then
        mmioClose hIn, 0
        MsgBox "Is not valid file"
        Exit Function
    End If
    ' Ищем чанк fmt, определяющий формат данных
    sInf.ckid = mmioStringToFOURCC("fmt", 0)
    If mmioDescend(hIn, sInf, inf, MMIO_FINDCHUNK) Then
        mmioClose hIn, 0
        MsgBox "Format chunk not found"
        Exit Function
    End If
    ' Проверяем размер
    If sInf.ckSize > Len(inpFmt) Then
        mmioClose hIn, 0
        MsgBox "Not supported format"
        Exit Function
    End If
    ' Читаем формат
    If mmioRead(hIn, inpFmt, sInf.ckSize) = -1 Then
        mmioClose hIn, 0
        MsgBox "Can't read format"
        Exit Function
    End If
    ' Запрашиваем у менеджера сжатия, может ли он преобразовать этот формат в нужный нам
    ret = acmStreamOpen(ByVal 0&, 0, inpFmt, mOutFmt, ByVal 0&, ByVal 0&, ByVal 0&, ACM_STREAMOPENF_QUERY)
    If ret Then
        mmioClose hIn, 0
        MsgBox "Can't convert wav file"
        Exit Function
    End If
    ' Выходим из чанка fmt
    mmioAscend hIn, sInf, 0
    ' Ищем чанк data с данными
    sInf.ckid = mmioStringToFOURCC("data", 0)
    If mmioDescend(hIn, sInf, inf, MMIO_FINDCHUNK) Then
        mmioClose hIn, 0
        MsgBox "Wave data not found"
        Exit Function
    End If
    ' Проверяем размер
    If sInf.ckSize <= 0 Then
        mmioClose hIn, 0
        MsgBox "Invalid data size"
        Exit Function
    End If
    ' Выделяем буфер и читаем данные
    ReDim buffer(sInf.ckSize - 1)
    If mmioRead(hIn, buffer(0), sInf.ckSize) = -1 Then
        mmioClose hIn, 0
        MsgBox "Can't read data"
        Exit Function
    End If
    ' Закрываем файл
    mmioClose hIn, 0
    ' Инициализация переменных
    mDataSize = sInf.ckSize
    bufIdx = 0
    mInpFmt = inpFmt
    ReadWaveFile = True
   
End Function

' // Получить сконвертированные данные
Public Function Convert(ByVal lpOutData As Long, ByVal dwCountBytes As Long, dwCountRead As Long) As Boolean
    Dim ret             As Long
    Dim inpCountBytes   As Long
    Dim acmHdr          As ACMSTREAMHEADER
    ' Проверка на инициализированность
    If Not mInit Then
        If Not Init() Then Exit Function
    End If
    ' Узнаем нужное количество данных во входном буфере для текущего запроса
    ret = acmStreamSize(hStream, dwCountBytes, inpCountBytes, ACM_STREAMSIZEF_DESTINATION)
    If ret Then Exit Function
    ' Корректируем размер с учетом выхода за пределы
    If inpCountBytes + bufIdx >= mDataSize Then
        inpCountBytes = mDataSize - bufIdx
       
        If inpCountBytes <= 0 Then
            Convert = True
            dwCountRead = 0
            Exit Function
        End If
       
    End If
    ' Заполняем заголовок преобразования
    With acmHdr
        .cbStruct = Len(acmHdr)
        .lppbDst = lpOutData
        .lppbSrc = VarPtr(buffer(bufIdx))
        .cbDstLength = dwCountBytes
        .cbSrcLength = inpCountBytes
    End With
    ' Подготавливаем к перекодировке
    ret = acmStreamPrepareHeader(hStream, acmHdr, 0)
    If ret Then Exit Function
    ' Перекодируем
    ret = acmStreamConvert(hStream, acmHdr, ACM_STREAMCONVERTF_BLOCKALIGN)
    ' Освобождаем
    acmStreamUnprepareHeader hStream, acmHdr, 0
    If ret Then Exit Function
    ' Возвращаем реальное число прочитанных байт
    dwCountRead = acmHdr.cbDstLengthUsed
    bufIdx = bufIdx + acmHdr.cbSrcLengthUsed
    ' Успех
    Convert = True
   
End Function

' // Инициализация потока ACM
Private Function Init() As Boolean
    Dim ret As Long
    ' Открываем поток для нужного преобразования
    ret = acmStreamOpen(hStream, 0, mInpFmt, mOutFmt, ByVal 0&, ByVal 0&, ByVal 0&, 0)
    If ret Then Exit Function
   
    Init = True
    mInit = True
End Function

Private Sub Class_Initialize()
    ' Выходной формат по умолчанию
    With mOutFmt
        .wFormatTag = 1
        .nChannels = 1
        .nSamplesPerSec = SampleRate
        .wBitsPerSample = 16
        .nBlockAlign = .wBitsPerSample \ 8 * .nChannels
        .nAvgBytesPerSec = .nSamplesPerSec * .nBlockAlign
    End With
End Sub

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

Разберем подробно код. Для открытия файла служит метод ReadWaveFile, в качестве аргумента он принимает имя wav-файла. Файл с расширением .wav представляет собой файл в формате 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:
Код: Выделить всё
' 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 приостанавливает воспроизведение. Назначение остальных свойств понятно из комментариев в коде.
Продолжение...
UA6527P

Вернуться в The trick

Кто сейчас на конференции

Сейчас этот форум просматривают: нет зарегистрированных пользователей и гости: 0

    TopList  
cron