Чт мар 09, 2023 11:00:26
Private Sub Form_Load()
Dim NumDevs As Integer
NumDevs = waveOutGetNumDevs() ' Определяем количество waveform-аудио выходных устройств в системе
' Определяем характеристики каждого waveform-аудио выходного устройства
For X = -1 To NumDevs - 1 ' и название устройства записываем в ComboBox начиная с Wave Mapper(WAVE_MAPPER = -1)
If MMSYSERR_NOERROR = waveOutGetDevCaps(X, woc, Len(woc)) Then
Combo1.AddItem woc.szPname, X + 1
End If
Next X
Combo1.Text = Combo1.List(0)
Initialize Me.hWnd
End Sub
Public Sub Initialize(hwndIn As Long)
hWnd = hwndIn
lpPrevWndProc = SetWindowLong(hWnd, GWL_WNDPROC, AddressOf WindowProc)
End Sub
Public Function WindowProc(ByVal hw As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Select Case uMsg
Case MM_WOM_DONE
OutWaveThRun
Case MM_WOM_CLOSE
Form1.Label1.Caption = "А тут Устройство закрыто"
Case MM_WOM_OPEN
Form1.Label1.Caption = "Опять Устройство открыто"
End Select
WindowProc = CallWindowProc(lpPrevWndProc, hw, uMsg, wParam, lParam)
End Function
Private Sub Combo1_Click() ' Проверяем, поддерживает ли выбранное устройство формат заложенный в wf
FormatDate
If MMSYSERR_NOERROR = waveOutOpen(0, Combo1.ListIndex - 1, wf, vbNull, 0, WAVE_FORMAT_QUERY) Then
Label1.Caption = "Формат поддерживается"
Else
Label1.Caption = "Формат не поддерживается"
End If
End Sub
Private Sub FormatDate() ' заполнение структуры формата буфера данных
Dim SpS&, BpS&
BpS = Text14.Text: SpS = Text15.Text
With wf
.wFormatTag = WAVE_FORMAT_PCM ' используется PCM формат
.nChannels = 1 ' это моносигнал (1 канал)
.nSamplesPerSec = SpS ' 44100 ' частота дискретизации 11,025-22,05-44,1 Кгц
.wBitsPerSample = BpS ' 16 ' выборка 16 бит
.nAvgBytesPerSec = (wf.nChannels * wf.nSamplesPerSec * wf.wBitsPerSample) / 8 ' число байт в секундном интервале для моносигнала
.nBlockAlign = (wf.nChannels * wf.wBitsPerSample) / 8 ' 1 * 16 / 8= 2 число байт в выбоке для моносигнала
.cbSize = Len(wf) ' не используется (можно .cbSize = 0)
End With
End Sub
Private Sub Command20_Click() ' включить генератор сигнала и, если включена запись, то пишем в файлы картинки
f = Text4.Text: omega = 2 * pi * f: Period = 1 / f : dVol=32767 ' частота, период и амплитуда колебаний
kSpeed = Text27.Text ' коэффициент увеличения буфера данных, т.е. для уменьшения заданной частоты
OutWaveThInit ' инициализируем устройство вывода, задаем размер буферов с учетом kSpeed и создаем эти буферы
tPred = 0 '
FillBuffer Buffer1, tPred ' заполняем два буфера данными для заданного сигнала
FillBuffer Buffer2, tPred
waveOutWrite hWaveOut, whdr1, Len(whdr1) ' выводим данные буфера 0
waveOutWrite hWaveOut, whdr2, Len(whdr2) ' выводим данные буфера 1
End Sub
Public Sub OutWaveThInit() ' Процедура init'а звукового потока (Открываем устройство вывода звука)
If MMSYSERR_NOERROR = waveOutOpen(hWaveOut, Form1.Combo1.ListIndex - 1, wf, hWnd, True, CALLBACK_WINDOW) Then
Form1.Label1.Caption = "Устройство открыто"
BufferSize = wf.nBlockAlign * wf.nSamplesPerSec * 0.5 * kSpeed ' Определяем размер буферов с учетом kSpeed
ReDim Buffer1(BufferSize - 1) ' задаем размерность массивов буферов
ReDim Buffer2(BufferSize - 1)
With whdr1
.lpData = VarPtr(Buffer1(0))
.dwBufferLength = BufferSize
'.dwBytesRecorded = 0
'.dwUser = 0
'.dwFlags = WHDR_BEGINLOOP Or WHDR_ENDLOOP Or WHDR_DONE
'.dwLoops = 1
'.lpNext = vbNull
'.Reserved = 0
End With
With whdr2
.lpData = VarPtr(Buffer2(0))
.dwBufferLength = BufferSize
'.dwBytesRecorded = 0
'.dwUser = 0
'.dwFlags = WHDR_BEGINLOOP Or WHDR_ENDLOOP Or WHDR_DONE
'.dwLoops = 1
'.lpNext = vbNull
'.Reserved = 0
End With
waveOutPrepareHeader hWaveOut, whdr1, Len(whdr1)
waveOutPrepareHeader hWaveOut, whdr2, Len(whdr2)
End If
End Sub
Public Sub FillBuffer(ByRef Buf() As Integer, ByRef tPred As Double)’ заполняем буфер данными
For X = 0 To BufferSize - 1
tt = X / wf.nSamplesPerSec / kSpeed + tPred
If Form1.Option1.Value = True Then Buf(X) = Round(dVol * Sin(omega * tt + Alfa))
Next X
tPred = tt
End Sub
Private Sub Command4_Click() ' выключить генратор сигнала
OutWaveThStop
End Sub
Public Const MAXPNAMELEN = 32 'max product name length (including NULL)
Public Const MMSYSERR_NOERROR = 0 'Нет ошибок
Public Const CALLBACK_WINDOW = &H10000
Public Const CALLBACK_EVENT = &H50000
Public Const WAVE_FORMAT_QUERY = &H1
Public Const WAVE_ALLOWSYNC = &H2
Public Const MM_WOM_CLOSE = &H3BC
Public Const MM_WOM_DONE = &H3BD
Public Const MM_WOM_OPEN = &H3BB 'waveform output
Public Const WHDR_BEGINLOOP = &H4 'loop start block
Public Const WHDR_DONE = &H1 'done bit
Public Const WHDR_ENDLOOP = &H8 'loop end block
Public Const WAVE_FORMAT_PCM = 1
Public Const GMEM_MOVEABLE = &H2
Public Const GMEM_SHARE = &H2000
Public Const pi = 3.14159265358979
Public Const GWL_WNDPROC = -4
Public whdr1 As WAVEHDR 'header звукового буфера N1
Public whdr2 As WAVEHDR 'header звукового буфера N2
Public BufferSize As Long ' Размер буфера
Public Buffer1() As Integer ' Буферы для звуковых данных (в зависимости от формата данных в wf,
Public Buffer2() As Integer ‘ буферы будут иметь разный размер, поэтому динамические массивы)
Public woc As WAVEOUTCAPS
Public wf As WAVEFORMATEX
Public hWaveOut As Long
Public tPred As Double, T0 As Double, T0pred As Double '
Public hWnd As Long
Public lpPrevWndProc As Long
Public X As Long, i As Long, ii As Long, j As Long, k As Long, kk As Long
Public t As Double, tt As Double, f As Double, dVol As Double
Public MT As Double, Vmax As Double
Public omega As Double
Public Alfa#, Info$ ' вспомогательный угол
Public kUgol#, kSignal# ' коэффициент перевода из градусов в радины и тангенс угла наклона треугольного сигнала
Public kSpeed& ' коэффициент уменьшения скорости воспроизведения
Public Period# ' период
Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Public Declare Function waveOutGetDevCaps Lib "winmm.dll" Alias "waveOutGetDevCapsA" (ByVal uDeviceID As Long, lpCaps As WAVEOUTCAPS, ByVal uSize As Long) As Long
Public Declare Function waveOutGetNumDevs Lib "winmm.dll" () As Long
Public 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 Long
Public Declare Function waveOutPrepareHeader Lib "winmm.dll" (ByVal hWaveOut As Long, lpWaveOutHdr As WAVEHDR, ByVal uSize As Long) As Long
Public Declare Function waveOutReset Lib "winmm.dll" (ByVal hWaveOut As Long) As Long
Public Declare Function waveOutPause Lib "winmm.dll" (ByVal hWaveOut As Long) As Long
Public Declare Function waveOutRestart Lib "winmm.dll" (ByVal hWaveOut As Long) As Long
'Public Declare Function waveOutUnprepareHeader Lib "winmm.dll" (ByVal hWaveOut As Long, lpWaveOutHdr As WAVEHDR, ByVal uSize As Long) As Long
Public Declare Function waveOutUnprepareHeader Lib "winmm.dll" (ByVal hWaveOut As Long, lpWaveOutHdr As Any, ByVal uSize As Long) As Long
Public Declare Function waveOutWrite Lib "winmm.dll" (ByVal hWaveOut As Long, lpWaveOutHdr As WAVEHDR, ByVal uSize As Long) As Long
Public Declare Function waveOutClose Lib "winmm.dll" (ByVal hWaveOut As Long) As Long
Public Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Public Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Public Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Public Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long
Public Type WAVEOUTCAPS 'Структура для waveOutGetDevCaps
wMid As Integer
wPid As Integer
vDriverVersion As Long
szPname As String * MAXPNAMELEN
dwFormats As Long
wChannels As Integer
dwSupport As Long
End Type
Type WAVEFORMATEX 'Структура для waveOutOpen
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
Чт мар 09, 2023 19:32:04
Пт мар 10, 2023 12:07:08
Пт мар 10, 2023 14:44:32
Сб мар 11, 2023 07:08:32