Option Explicit
Implements DirectXEvent8
'Сам DirectX8
Private objDX8 As DirectX8
'Объект для захвата звука
Private objDSCapture As DirectSoundCapture8
'Буфер, куда пудет записываться звук
Private objDSCaptureBuffer As DirectSoundCaptureBuffer8
'Дескриптор для создания буфера
Private CaptureDesc As DSCBUFFERDESC
'Это для обработки событий буфера
' последняя позиция, на которой произошло событие
Private lastPos As Long
' сколько всего байтов записали
Private BytesWritten As Long
' идентификатор события остановки
Private EventStop As Long
' идентификатор собый, возникающих во время записи
Private EventNotify As Long
'возможности захватывающего устройства
Private CaptureCaps As DSCCAPS
'Эти три типа нужны для записи в WAV-файл
' заголовок файла
Private Type FileHeader
lRiff As Long
lFileSize As Long
lWave As Long
lFormat As Long
lFormatLength As Long
End Type
' формат WAV
Private Type WaveFormat
wFormatTag As Integer
nChannels As Integer
nSamplesPerSec As Long
nAvgBytesPerSec As Long
nBlockAlign As Integer
wBitsPerSample As Integer
End Type
Private Type ChunkHeader
lType As Long
lLen As Long
End Type
Dim fh As FileHeader
Dim wf As WaveFormat
Dim ch As ChunkHeader
Private Sub cmdInitObjects_Click()
'Здесь инициализируются необходимые объекты
' это для определния поддерживаемых ыорматов
Dim lngFormats As CONST_WAVEFORMATFLAGS
'создаем экзепляр DirectX8
Set objDX8 = New DirectX8
'Создаем два события
' остановка захвата
EventStop = objDX8.CreateEvent(Me)
' во время захвата
EventNotify = objDX8.CreateEvent(Me)
'Создаем объект для захвата. В параметре указана vbNullString, что означает, что
'нами будет использоваться устройство захвата по умолчанию
Set objDSCapture = objDX8.DirectSoundCaptureCreate(vbNullString)
'Получим возможность устройства
objDSCapture.GetCaps CaptureCaps
'Заполним список поддерживаемых форматов
lngFormats = CaptureCaps.lFormats
lstFormats.Clear
'Поочередно проверим на соответствие с каждым из допустимых
If (lngFormats And WAVE_FORMAT_1M08) > 0 Then lstFormats.AddItem "11.025 kHz, mono, 8-bit"
If (lngFormats And WAVE_FORMAT_1M16) > 0 Then lstFormats.AddItem "11.025 kHz, mono, 16-bit"
If (lngFormats And WAVE_FORMAT_1S08) > 0 Then lstFormats.AddItem "11.025 kHz, stereo, 8-bit"
If (lngFormats And WAVE_FORMAT_1S16) > 0 Then lstFormats.AddItem "11.025 kHz, steroe, 16-bit"
If (lngFormats And WAVE_FORMAT_2M08) > 0 Then lstFormats.AddItem "22.05 kHz, mono, 8-bit"
If (lngFormats And WAVE_FORMAT_2M16) > 0 Then lstFormats.AddItem "22.05 kHz, mono, 16-bit"
If (lngFormats And WAVE_FORMAT_2S08) > 0 Then lstFormats.AddItem "22.05 kHz, stereo, 8-bit"
If (lngFormats And WAVE_FORMAT_2S16) > 0 Then lstFormats.AddItem "22.05 kHz, stereo, 16-bit"
If (lngFormats And WAVE_FORMAT_4M08) > 0 Then lstFormats.AddItem "44.1 kHz, mono, 8-bit"
If (lngFormats And WAVE_FORMAT_4M16) > 0 Then lstFormats.AddItem "44.1 kHz, mono, 16-bit"
If (lngFormats And WAVE_FORMAT_4S08) > 0 Then lstFormats.AddItem "44.1 kHz, stereo, 8-bit"
If (lngFormats And WAVE_FORMAT_4S16) > 0 Then lstFormats.AddItem "44.1 kHz, stereo, 16-bit"
End Sub
Private Sub cmdCreateBuffer_Click()
'Здесь создадим и проинициализируем буфер
'Будет 3 уведомления
Dim tmp(0 To 2) As DSBPOSITIONNOTIFY
'первые два - по ходу записи
With tmp(0)
.lOffset = 10000
.hEventNotify = EventNotify
End With
With tmp(1)
.lOffset = 30000
.hEventNotify = EventNotify
End With
'а это по завершении
With tmp(2)
.lOffset = DSBPN_OFFSETSTOP
.hEventNotify = EventStop
End With
'укажем формат захвата звука
With CaptureDesc.fxFormat
.nFormatTag = WAVE_FORMAT_PCM
.nChannels = 2
.lSamplesPerSec = 44100 '22050
.nBitsPerSample = 16
.nBlockAlign = .nBitsPerSample / 8 * .nChannels
.lAvgBytesPerSec = .lSamplesPerSec * .nBlockAlign
.nSize = 0
End With
CaptureDesc.lFlags = DSCBCAPS_DEFAULT
'Размер буфера. В данном случае 5 секунд
CaptureDesc.lBufferBytes = CaptureDesc.fxFormat.lAvgBytesPerSec * 5
'Создадим буфер
Set objDSCaptureBuffer = objDSCapture.CreateCaptureBuffer(CaptureDesc)
'Добавим три уведомления
objDSCaptureBuffer.SetNotificationPositions 3, tmp
End Sub
Private Sub cmdCreateWAV_Click()
'Путь к файлц
Dim strPath As String
strPath = txtPath.Text
'Откроем файл для двоичного доступа на запись
Open strPath For Binary Access Write As #1
'Запишем заголовки
With fh
.lRiff = &H46464952
.lFileSize = 0 ' Размер файла узнаем позже
.lWave = &H45564157
.lFormat = &H20746D66
.lFormatLength = Len(wf)
End With
Put #1, , fh
With wf
.wFormatTag = CaptureDesc.fxFormat.nFormatTag
.nChannels = CaptureDesc.fxFormat.nChannels
.nSamplesPerSec = CaptureDesc.fxFormat.lSamplesPerSec
.wBitsPerSample = CaptureDesc.fxFormat.nBitsPerSample
.nBlockAlign = CaptureDesc.fxFormat.nBlockAlign
.nAvgBytesPerSec = CaptureDesc.fxFormat.lAvgBytesPerSec
End With
Put #1, , wf
ch.lType = &H61746164
Put #1, , ch
End Sub
Private Sub cmdStart_Click()
'Начнем запись. DSCBSTART_LOOPING означает, что захват будет вестись бесконечно,
'пока не будет остановлен вручную.
objDSCaptureBuffer.Start DSCBSTART_LOOPING
End Sub
Private Sub cmdStop_Click()
'А вот и эта ручная остановка
objDSCaptureBuffer.Stop
End Sub
'А вот и обработка событий буфера
Private Sub DirectXEvent8_DXCallback(ByVal eventid As Long)
'Здесь будет текущее положение курсора
Dim curPos As Long
Dim curs As DSCURSORS
'Это считанные данные
Dim dataBuf() As Byte
'А это размер считанных данных
Dim dataSize As Long
'Узнаем текущую позицию
objDSCaptureBuffer.GetCurrentPosition curs
curPos = curs.lWrite ' Вполть до этой позиции можно считывать данные
'Узнаем, сколько байт накопилось с прошлой записи в файл,
'получив разность между текущим положением курсора и прошлым
dataSize = curPos - lastPos
'Если эта разница меньше 0, то значит, что с прошлой записи
'курсор дошел до конца и запись вновь началась с начала буфера.
'Тогда размер данных складывается из двух: того, что прошел с начала
'буфера (curPos), и того, что оставался с момента прошлого вызова:
'<размер буфера>-lastPos.
If dataSize < 0 Then
dataSize = (CaptureDesc.lBufferBytes - lastPos) + curPos
End If
'Переопределим размер локального буфера
ReDim dataBuf(dataSize - 1)
'И считаем в него данные
objDSCaptureBuffer.ReadBuffer lastPos, dataSize, dataBuf(0), DSCBLOCK_DEFAULT
'Запишем эти данные и увеличим счетчик записанных байтов
Put #1, , dataBuf
BytesWritten = BytesWritten + dataSize
lblBytesWritten.Caption = BytesWritten
lastPos = curPos
'Это так, для отладки
Select Case eventid
Case EventStop
Debug.Print "DxEvent::Stop:: всего байт записали " & BytesWritten
Case EventNotify
Debug.Print "DxEvent::Notify:: в этом событии записали " & dataSize & " байт"
End Select
'Если событие "Остановка", то завершим запись в файл
If (eventid = EventStop) Then
CloseFile
End If
End Sub
Private Sub CloseFile()
Dim fsize As Long
'А теперь вернемся к прощенному: размер файла - теперь он нам известен
fsize = Len(fh) + Len(wf) + Len(ch) + BytesWritten
Put #1, 5, fsize
' Rewrite data chunk header with size.
'То же и с Chunk
ch.lLen = BytesWritten
Put #1, Len(fh) + Len(wf) + 1, ch
Close #1
End Sub
Private Sub Form_Unload(Cancel As Integer)
'Ну а теперь надо зачистить все за собой
'Для начала проверим, остановлен ли захват
'Если нет, то нажмем на кнопку "Стоп"
If (objDSCaptureBuffer.GetStatus And DSCBSTATUS_CAPTURING) > 1 Then
cmdStop.Value = True
End If
'Удалим события
objDX8.DestroyEvent EventStop
objDX8.DestroyEvent EventNotify
'А теперь уничтожим объекты
Set objDSCaptureBuffer = Nothing
Set objDSCapture = Nothing
Set objDX8 = Nothing
End Sub
|
