Option Explicit 'Это ясно :)

'Установка типа переменных
Public hWaveIn& 'Контейнер уровня входа
Private bBufferFull As Boolean 'Контейнер статуса буфера (памяти); Лож/Истина
Private WaveData( 255 ) As Byte 'Звуковые данные

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

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

Type WAVEINCAPS 'Данные в колпачке
wMid As Integer 'Середина
wPid As Integer 'Пики (Peak)
vDriverVersion As Long 'Версия драйвера (системного)
szPname As String *  32  'Имя порта (Канала/Драйвера)
dwFormats As Long 'Нижеописанные форматы
wChannels As Integer 'Количество каналов
End Type

'Все библиотеки использованные в проекте
'Подробно ищите в интернете, не охота описовать или доке по API
Declare Function waveInAddBuffer Lib "winmm.dll" (ByVal hWaveIn As Long, lpWaveInHdr As WAVEHDR, ByVal uSize As Long) As Long
'Получиене количества звуковых устройств ( 0  при отсутсвии)
Declare Function waveInGetNumDevs Lib "winmm.dll" () As Long
'Открыть звуковой вход
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
'Получить заголовок (канала)
Declare Function waveInPrepareHeader Lib "winmm.dll" (ByVal hWaveIn As Long, lpWaveInHdr As WAVEHDR, ByVal uSize As Long) As Long
'Сброс данных входа
Declare Function waveInReset Lib "winmm.dll" (ByVal hWaveIn As Long) As Long
'Открыти приёмного канала
Declare Function waveInStart Lib "winmm.dll" (ByVal hWaveIn As Long) As Long
'Отсановка приёма байтов входного канала
Declare Function waveInStop Lib "winmm.dll" (ByVal hWaveIn As Long) As Long
'Закрытие звукогого канала
Declare Function waveInClose Lib "winmm.dll" (ByVal hWaveIn As Long) As Long
'Негтовые (необработанные) заголовки
Declare Function waveInUnprepareHeader Lib "winmm.dll" (ByVal hWaveIn As Long, lpWaveInHdr As WAVEHDR, ByVal uSize As Long) As Long
'Установкаместоположения окна
Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long

Public Const CALLBACK_FUNCTION = &H30000 'Функция возврата
Public Const MM_WIM_DATA = &H3C0 'Контейнер переобразование данных
Public Const WAVE_FORMAT_PCM =  1  'Формат данных (1 по умолч.)
Public Const WAVE_MAPPER = -1& 'Wave Mapper системное устройство наблюдения за звуком

'Форматы (звуковых) данных
Public Const WAVE_FORMAT_1M08 = &H1 '  11025  Гц,  8  Бит, Моно.
Public Const WAVE_FORMAT_2M08 = &H10 ' 22050 Гц, 8 Бит, Моно.
Public Const WAVE_FORMAT_4M08 = &H100 '  44100  Гц,  8  Бит, Моноo.

'Расположение окна
Global Const HWND_TOP = 0 'Константа окно на пункт верх
Global Const HWND_TOPMOST = - 1  'Поверх всех окон
Global Const HWND_NOTOPMOST = -2 'Не повер всех окон (возврат в старое место)
Global Const SWP_NOMOVE =  2  'Не перетаскивать
Global Const SWP_NOSIZE = 1 'Не изменять размер
Global Const FLAGS = SWP_NOMOVE Or SWP_NOSIZE 'Флаги
Private Sub Main()
'Отсюда всё и начинается
#If Win32 Then 'Если система 32-разрядная то
If PrevInst Then End 'Если другая копия загружена не загружать эту
If Not WaveInPresent Then End 'Если нет звукого устройства ввода, завершит программу
frmMain.Show 'Отображать главное окно
#Else 'В противном случае (Если Винда не 32 а 16)
End 'Выйти с программы ничего не сделав
#End If
End Sub
Private Function PrevInst() As Boolean
'Если уже загружена одна копия, не дать повторно загружать вторую
If App.PrevInstance Then
MsgBox "Уже загружена одна копия " & App.Title & "." & vbCrLf & "Нельзя загружать более одной копии.", vbExclamation + vbMsgBoxSetForeground
PrevInst = True
Else 'В противном случае продолеть загрузку
PrevInst = False
End If
End Function
Private Function WaveInPresent() As Boolean
'Получение количества звуковых устройств
If waveInGetNumDevs() > 0 Then 'Если присуствует одно или более устройство
WaveInPresent = True 'То Устройство входа сушествует
Else 'В противном случае
'Сообшим пользоваелю об ошибке
MsgBox "Невозможно определить ниодно устройство ввоза звука." & _
vbCrLf & "Возможно в системе неть звукавой карты или она неисправна." _
, vbCritical, "Ошибка в " & App.Title
WaveInPresent = False 'Как никак, но карты нету (или непонятная)
End If
End Function
Public Sub waveInProc(ByVal hwi&, ByVal uMsg&, ByVal dwInstance&, ByVal dwParam1&, ByVal dwParam2&)
'ВНИМАНИЕ!
'Не вызывайте ниодной системной функции из этой рутины.
'Вызов других звуковых функций можеть вызвать зависание.

'Состояние буфера: заполнен (занят) или нет
If uMsg = MM_WIM_DATA Then bBufferFull = True

End Sub
Private Sub DrawSpect() 'для красоты по разному
'Рисовать спектраль (в главной форме, в елементе pctSpec)
'x% - это длина шкалы (окошка обзора)
'c% - это данные из звукого источника (в виде байтов)
'i% - это просто контейнер для хранения цифр
Dim X%, c%, i%, j%
frmMain.pctSpec.Cls 'Очищаю всё что было нарисовано в яшике рисунка
For X% =  0  To  254  'Начнём круг и возмём все 254 (зачем не 255?)
c% = WaveData(X%) 'Как и описывал, это контейнер звуковых данных
'В зависимости от выбранного стиля рисуем в картинке спектр
With frmMain
Select Case .cmbStyle.ListIndex
Case 0 'Обычный (верхний/полавинчетый)
.pctSpec.Line (X%, c%)-(X%,  256 ), Col(c%)
Case  1  'Осевой - Рисует полную ось: верхюю и нижнию часть
.pctSpec.Line (X%, c%)-(X%, 128), Col(c%)
Case 2 'Точечный - Рисует точку в указаннвх кординатах
.pctSpec.PSet (X%, c%), Col(c%)
Case  3  'Линейный - Рисует лиюнию в до нового кордината от старого кордината
.pctSpec.Line -(X%, c%), Col(c%)
Case 4 'Колечки
.pctSpec.Circle (X%, c%),  2 , Col(c%)
Case  5  'Паралель
.pctSpec.PSet (X%, 112 - c% / 3), vbYellow
.pctSpec.PSet (X%, c% / 3 + 144), vbCyan
Case 6 'Растяжка (линия между двумя точками)
.pctSpec.Line (X%,  128  - c% /  2 )-(X%, c% /  2  +  128 ), Col(c%)
Case  7  'Неатив
.pctSpec.Line (X%, 0)-(X%, c%), Col(c%)
Case Else
End Select
End With
Next X%
End Sub
Public Function Col(CV) As ColorConstants
'Функция для получения цвета в зависимости от звукого банка
Select Case frmMain.cmbColor.ListIndex 'Выбор цвета окраски
Case 0 'Смещанный - Определение по уровню
If CV >  0  And CV  24  And CV  64  And CV  192  And CV  232  And CV  256  Then MsgBox "Хе хе! Бит больше " & CV 'Может и такое быть! :)
Case 1
Col = vbBlue 'Синий
Case  2 
Col = vbCyan 'Голубой
Case 3
Col = vbGreen 'Зелённым (по умолч.)
Case  4 
Col = vbMagenta 'Лиловый
Case 5
Col = vbRed 'Красный
Case  6 
Col = vbWhite 'Белый
Case 7
Col = vbYellow 'Жёлтый
Case Else
End Select
End Function
Public Sub MonitorAudio()
'Мониторинг (наблюдение) за звуком в входном канале
Dim WH As WAVEHDR 'Определим WH как записанный буфер из памяти

waveInStart hWaveIn 'Откуда и как начать

Do 'Начать весь процесс (тот зачем прога создана)
With WH 'Чтоб повторно не писать WH (WAVEHDR) и чтоб не путал каналы
.lpData = VarPtr(WaveData(0)) 'Где взять данные
.dwBufferLength =  256  'Длина буфера (По умолч. 256, но можно и 128)
.dwFlags = 0 'Никаких флажков, чтоб просто работало
End With

waveInPrepareHeader hWaveIn, WH, Len(WH) 'Куда направить, и откуда
bBufferFull = False 'Очисщен буфер, но и контейнер тоже
waveInAddBuffer hWaveIn, WH, Len(WH) 'Добавить звук в буфер

Do 'Начать цикл
DoEvents 'Чтоб не висло...
Loop Until bBufferFull Or hWaveIn = 0 'Пока буфер не переполнен или вход равен нулю

waveInUnprepareHeader hWaveIn, WH, Len(WH) 'Передаём необработанные данные
DrawSpect 'Рисование спектров

DoEvents 'Чтоб не висло и никого не ждало
Loop Until hWaveIn = 0 'Продожить до опусташения
End Sub


Forma
'Данный исходный код демонстрирует как можно получать байты с звукого устройства
'Как определить звуковой спектор
'Как построит простой, половинчетый, линейный и точечный анализатор звукого сигнала
'Как работать с библиотекой "winmm.dll"
'автор кода Алиев Рашид (не я).
Private m As Integer
Private Sub chkOnTop_Click()
'При нажатии мышю изменить расположение окна: повер/не всех окон
If chkOnTop.Value = vbChecked Then 'Если птичка стоит то
'Сделать поверх всех окон (будет всегда стоять на экране)
SetWindowPos frmMain.hwnd, HWND_TOPMOST,  0 ,  0 ,  0 ,  0 , FLAGS
Else
'Вернуть старое расположене окна
SetWindowPos frmMain.hwnd, HWND_NOTOPMOST, 0, 0, 0, 0, FLAGS
End If
End Sub
Private Sub chkX2_Click()
pctSpec.DrawWidth = 1 + chkX2.Value
End Sub
Private Sub cmdAbout_Click()
'Как автор программы имею право на эту кнопку :)
'Задаём текст для ящика "Автор"
MsgBox App.Title & Space(1) & App.Major & "." & App.Minor & vbCrLf & vbCrLf & _
"Автор:" & vbTab & "Рашид Алиев" & vbCrLf & App.Comments & vbCrLf & vbCrLf & "Описание: " & App.FileDescription
End Sub
Private Sub cmdExit_Click()
Unload frmMain 'Передать всё в пункт выгрузки
End Sub
Private Sub cmdStart_Click() 'Запуск всего :)
Dim Rv&
Dim WF As WAVEFORMATEX

cmbStyle.SetFocus

With WF 'Указываем откуда и как читать данные
.wFormatTag = WAVE_FORMAT_PCM 'Формат файла
.nChannels = 1 'Каналы
.nBlockAlign =  1 
.nSamplesPerSec =  11025  'Формат 11/22/44 Гц
.wBitsPerSample = 8 'Семпл ( 8  по умолч. но можнои  16 , но сначала надо указать опредеение в SpecAnalyzer)
.nAvgBytesPerSec = (.nSamplesPerSec * .nBlockAlign) \  8 
.cbSize =  0  'Размер буфера (не того о чем вы подумали ;)
End With

'Открыть каналчик и пистаь
Rv = waveInOpen(hWaveIn, WAVE_MAPPER, WF, AddressOf waveInProc,  0 , CALLBACK_FUNCTION)
If Rv  0  Then 'Если нет сигнала
MsgBox "Невозможно открыть устройство ввода звука." & vbCrLf & _
"Возможно он занят или используется другим приложением.", vbCritical, "Ошибка в " & App.Title
Exit Sub 'Просто выйдем
End If

DoEvents 'Чтоб не висло

'Вызваем то зачем всё это создали,
'т.е. модуль чтения и рисования спектрума
MonitorAudio

End Sub
Private Sub cmdStop_Click()

cmbStyle.SetFocus 'Передача фокуса

waveInReset hWaveIn 'Отрубит
waveInStop hWaveIn 'Остановить
waveInClose hWaveIn 'Закрыт
hWaveIn = 0 'Очистить

If chkStopCLS.Value = vbChecked Then pctSpec.Cls

DoEvents 'Чтоб не висло и продолжело работу системы
End Sub
Private Sub Form_Load()
m = 0
cmbStyle.ListIndex = 0
cmbColor.ListIndex = 3
'Даём заголовок из свойства заголовок
frmMain.Caption = App.Title & Space( 1 ) & App.Major & "." & App.Minor
chkOnTop.Value = vbChecked 'Чтоб при запуске был поверх всех (не надо будет кликать)
End Sub
Private Sub Form_QueryUnload(Cancel%, UnloadMode%)
'Отключть монитор и завершить работу программы
'Если остановит возможно (т.е. работает), то остановить (вызвать клик на кнопку стоп)
If cmdStop.Enabled Then cmdStop_Click
Unload frmMain 'Выгрузить форму с памяти
Set frmMain = Nothing 'Очитстить место завнимаемое в ОЗУ
End 'Завершит работу
End Sub
Private Sub pctSpec_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
'При клике на спектрум циркулировать стили
Select Case Button
Case  1 
m = m +  1 
If m >  7  Then m =  0 
Case  2 
m = m -  1 
If m <  0  Then m =  7 
Case Else
End Select
cmbStyle.ListIndex = m
End Sub