modAudio.bas module:
Code:
Option Explicit
' Модуль modAudio.bas для захвата звука в программе TrickSpectrum
' © Кривоус Анатолий Анатольевич (The trick), 2014
Public 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
Public 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
Public Type BUFFER ' Структура буфера
Data() As Integer ' Данные
Header As WAVEHDR ' Заголовок
End Type
Public 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 Long
Public Declare Function waveInPrepareHeader Lib "winmm.dll" (ByVal hWaveIn As Long, lpWaveInHdr As WAVEHDR, ByVal uSize As Long) As Long
Public Declare Function waveInReset Lib "winmm.dll" (ByVal hWaveIn As Long) As Long
Public Declare Function waveInStart Lib "winmm.dll" (ByVal hWaveIn As Long) As Long
Public Declare Function waveInStop Lib "winmm.dll" (ByVal hWaveIn As Long) As Long
Public Declare Function waveInUnprepareHeader Lib "winmm.dll" (ByVal hWaveIn As Long, lpWaveInHdr As WAVEHDR, ByVal uSize As Long) As Long
Public Declare Function waveInClose Lib "winmm.dll" (ByVal hWaveIn As Long) As Long
Public Declare Function waveInGetErrorText Lib "winmm.dll" Alias "waveInGetErrorTextA" (ByVal err As Long, ByVal lpText As String, ByVal uSize As Long) As Long
Public Declare Function waveInAddBuffer Lib "winmm.dll" (ByVal hWaveIn As Long, lpWaveInHdr As WAVEHDR, ByVal uSize As Long) As Long
Public Const mSampleRate As Long = 44100 ' Частота дискретизации
Public Const BufSizeMS As Single = 0.03 ' Размер буфера в секундах
Public Const WAVE_MAPPER = -1&
Public Const CALLBACK_WINDOW = &H10000
Public Const WAVE_FORMAT_PCM = 1
Public Const MM_WIM_DATA = &H3C0
Dim hWave As Long ' Дескриптор записывающего устройства
Dim Fmt As WAVEFORMATEX ' Формат записи
Dim Buffers() As BUFFER ' Буферы
' Функция инициализирует запись
Public Function InitCapture() As Boolean
Dim ret As Long, msg As String, i As Long, count As Long
' Задаем формат записи
With Fmt
.cbSize = 0
.wFormatTag = WAVE_FORMAT_PCM
.wBitsPerSample = 16
.nSamplesPerSec = mSampleRate
.nChannels = 2
.nBlockAlign = .nChannels * .wBitsPerSample / 8
.nAvgBytesPerSec = .nSamplesPerSec * .nBlockAlign
End With
' Вычисляем размер буфера в выборках
count = Fmt.nAvgBytesPerSec * BufSizeMS
count = count - (count Mod Fmt.nBlockAlign)
' Открываем устройство записи
ret = waveInOpen(hWave, WAVE_MAPPER, Fmt, frmMain.hwnd, 0, CALLBACK_WINDOW)
If ret Then ShowMessage ret: Exit Function
' 4 буфера
ReDim Buffers(3)
' Подготовка буферов
For i = 0 To UBound(Buffers)
With Buffers(i)
ReDim .Data(count - 1)
.Header.lpData = VarPtr(.Data(0))
.Header.dwBufferLength = count * 2
.Header.dwFlags = 0
.Header.dwLoops = 0
ret = waveInPrepareHeader(hWave, .Header, Len(.Header))
If ret Then ShowMessage ret: Exit Function
End With
Next i
' Отправка буферов устройству
For i = 0 To UBound(Buffers)
ret = waveInAddBuffer(hWave, Buffers(i).Header, Len(Buffers(i).Header))
If ret Then ShowMessage ret: Exit Function
Next i
' Начинаем запись
ret = waveInStart(hWave)
If ret Then ShowMessage ret: Exit Function
' Успешно
InitCapture = True
End Function
' Процедура останавливает запись
Public Sub EndCapture()
Dim i As Long
' Сброс устройства и возвращение всех буферов приложению
waveInReset hWave
' Остановка записи
waveInStop hWave
' ОСвобождение заголовков буферов
For i = 0 To UBound(Buffers)
waveInUnprepareHeader hWave, Buffers(i).Header, Len(Buffers(i).Header)
Next
' Закрытие устройства записи
waveInClose hWave
End Sub
' Функция вызывается при очередном заполненном буфере
Public Function OnCapture(Hdr As WAVEHDR) As Boolean
Dim i As Long
' Получаем индекс буфера
i = modAudio.GetBufferIndex(Hdr.lpData)
If i = -1 Then Exit Function
' Вызываем отрисовку
modMain.Draw modAudio.Buffers(i).Data
' Отправка буфера устройству
waveInAddBuffer hWave, Buffers(i).Header, Len(Buffers(i).Header)
End Function
' Функция возвращает индекс буфера по его указателю
Private Function GetBufferIndex(ByVal Ptr As Long) As Long
Dim i As Long
For i = 0 To UBound(Buffers)
If Buffers(i).Header.lpData = Ptr Then GetBufferIndex = i: Exit Function
Next
GetBufferIndex = -1
End Function
' Процедура показывает сообщение об ошибке
Private Sub ShowMessage(ByVal Code As Long)
Dim msg As String
msg = Space(255)
waveInGetErrorText Code, msg, Len(msg)
MsgBox "Error capture." & vbNewLine & msg
End Sub