VIDEO
Всем привет. Создавая музыку, я видел много разных виртуальных инструментов и эффектов. Одним из интереснейших эффектов является вокодер, который позволяет промодулировать голос и сделать его например похожим на голос робота или что-то в этом духе. Вокодер изначально использовался для сжатия речевой информации, а после его начали применять в музыкальной сфере. Т.к. у меня появилось свободное время, я решил написать что-то подобное ради эксперимента и подробно описать этапы разработки на VB6.Audio Compression Manager (ACM ), с ним очень удобно производить конвертирование между форматами (т.к. файл может быть любого формата, то пришлось бы писать несколько функций для разных форматов). Может так оказаться что для конвертирования в нужный формат не окажется нужного ACM драйвера, тогда воспроизведение этого файла будет недоступным (хотя можно это попробовать сделать в 2 этапа). В качестве входных файлов будем использовать wav - файлы, т.к. для работы с ними в системе есть специальные функции облегчающие получение данных из них. Вот сам исходный код класса clsTrickWavConverter :Visual Basic 1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
' 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 :Visual Basic 1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
' 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 Sub memcpy Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source 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 приостанавливает воспроизведение. Назначение остальных свойств понятно из комментариев в коде.Продолжение...
