VBNet - Форум - Генератор белого шума

Вопрос: Генератор белого шума Добавлено: 11.01.09 01:03

Автор вопроса: Андрей

Написал наконец-то генератор шума. Вещь!!! Но бесполезная((( Может кому пригодиться для эффектов или замены Beep.

Вызывается:
VBSuperBeep 1000 'число - время звучания (мс)

Код модуля:

Option Explicit

Public Declare Function PlaySound Lib "winmm.dll" Alias "PlaySoundA" (lpszName As Any, ByVal hModule As Long, ByVal dwFlags As Long) As Long
Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Public Const SND_ASYNC = &H1
Public Const SND_MEMORY = &H4
Public Const SND_LOOP = &H8

Public Type WAVHEADER
    sigRIFF(3) As Byte    ' должно быть равно "RIFF"
    sizeRIFFch As Long    ' размер чанка RIFF
    sigWAVE(3) As Byte    ' должно быть равно "WAVE"
    sigFMT(3) As Byte    ' должно быть равно "fmt "
    sizeFMTch As Long    ' размер чанка FMT
    wFormatTag As Integer  ' категория формата, для PCM = 1
    wChannels As Integer   ' кол-во каналов: 1-моно 2-стерео
    dwSamplesPerSec As Long ' кол-во сэмплов в сек.
    dwAvgBytesPerSec As Long ' среднее число байт в сек
    wBlockAlign As Integer  ' выравнивание данных в дата-чанке
    wBitPerSample As Integer ' бит в сэмпле
    sigDATA(3) As Byte    ' должно быть равно "data"
    sizeDATAch As Long    ' размер data-чанка
End Type

Const ARYCNT = 1 ' предел генерации чисел

Public MinInt As Long
Public MaxInt As Long
Private mdblSeed(ARYCNT - 1) As Double
Private mintP As Integer
Private mintQ As Integer

Sub VBSuperBeep(dwMilliseconds As Long)
' частота дискретизации = 44100 Гц
' кол-во бит на сэмпл = 8
Dim Head As WAVHEADER

' длина дорожки в байтах
Dim numSamples As Long
numSamples = 44100

' выделяем память под дорожку
Dim Size As Long
Size = Len(Head) + numSamples

Dim buff() As Byte
ReDim buff(1 To Size)

'заполняем WAV-header
StrCpy Head.sigRIFF, "RIFF"
StrCpy Head.sigWAVE, "WAVE"
Head.sizeRIFFch = Size - 8
StrCpy Head.sigFMT, "fmt "
Head.sizeFMTch = 16
Head.wFormatTag = 1
Head.wChannels = 1 ' моно
Head.dwSamplesPerSec = 44100
Head.dwAvgBytesPerSec = 44100
Head.wBlockAlign = 1
Head.wBitPerSample = 8
StrCpy Head.sigDATA, "data"
Head.sizeDATAch = Size

'копируем его в буфер
CopyMemory buff(1), Head, Len(Head)

Dim lpSamp As Long 'BYTE *samples = (BYTE*)(head+1)
lpSamp = Len(Head) + 1

'заполняем дорожку случайными числами
Dim i As Long, b As Long
For i = 0 To numSamples - 1
    'b = Abs(255 * Sin(20 * 3.14159265358979 * i)) '255 - max-громкость
    b = Abs(255 * Random) '255 - max-громкость
    buff(i + lpSamp) = CByte(b)
Next

'проигрываем звук
PlaySound buff(1), 0, SND_ASYNC Or SND_LOOP Or SND_MEMORY

'ждём заданное количество миллисекунд
Sleep dwMilliseconds

'останавливаем звук
PlaySound ByVal vbNullString, 0, SND_ASYNC
End Sub

Private Sub StrCpy(Arr() As Byte, Expr As String)
    'Если нижняя граница массива >= 0(значит установлен массив)
    'И длина строки >= длине массива(лишь бы она не была меньше длины массива),
    'то копируем из ее содержимого столько байт, сколько длина массива
    If LBound(Arr) >= 0 And Len(Expr) >= UBound(Arr) + 1 Then
        CopyMemory Arr(0), ByVal Expr, UBound(Arr) + 1
    Else
        MsgBox "Не правильные аргументы в процедуре StrCpy!", vbCritical
        Stop
    End If
End Sub

' Генератор случайных чисел
Property Get Random() As Double
    mintP = (mintP + 1) Mod ARYCNT
    mintQ = (mintQ + 1) Mod ARYCNT
    mdblSeed(mintP) = mdblSeed(mintP) + mdblSeed(mintQ) + Rnd
    mdblSeed(mintP) = mdblSeed(mintP) - Int(mdblSeed(mintP))
    Random = mdblSeed(mintP)
End Property

Public Sub Shuffle(dblX As Double)
    Dim strN As String
    Dim intI As Integer
    Zap
    strN = Str$(dblX)
    For intI = 1 To Len(strN)
        Stir 1 / Asc(Mid(strN, intI, 1))
    Next intI
    Randomize Rnd(mdblSeed(mintP) * Sgn(dblX))
    For intI = 1 To ARYCNT * 2.7
        Stir Rnd
    Next intI
End Sub

Property Get RandomInt() As Long
    RandomInt = Int(Random() * (MaxInt - MinInt + 1)) + MinInt
End Property

Private Sub Zap()
    Dim intI As Integer
    For intI = 1 To ARYCNT - 1
        mdblSeed(intI) = 1 / intI
    Next intI
    mintP = ARYCNT \ 2
    mintQ = ARYCNT \ 3
    If mintP = mintQ Then
        mintP = mintP + 1
    End If
End Sub

Private Sub Stir(dblX As Double)
    mintP = (mintP + 1) Mod ARYCNT
    mintQ = (mintQ + 1) Mod ARYCNT
    mdblSeed(mintP) = mdblSeed(mintP) + mdblSeed(mintQ) + dblX
    mdblSeed(mintP) = mdblSeed(mintP) - Int(mdblSeed(mintP))
End Sub

Ответить

Ответы Всего ответов: 3

Номер ответа: 1 Автор ответа: Alex Вопросов: 10 Ответов: 131	Профиль \| \| #1	Добавлено: 11.01.09 02:12
	Да, согласен, бесполезная но прикольная!!! +1 Ответить

Номер ответа: 2 Автор ответа: Imperial Kashak ICQ: 479713821 Вопросов: 10 Ответов: 57	Профиль \| \| #2	Добавлено: 15.01.09 22:33
	Юмор! Ответить

Номер ответа: 3 Автор ответа: Sharp Лидер форума ICQ: 216865379 Вопросов: 106 Ответов: 9979	Web-сайт: sharpc.livejournal.com Профиль \| \| #3	Добавлено: 16.01.09 01:29
	Белый шум равномерен по спектру, а не по амплитудно-временным отсчетам. И я не взялся бы доказывать, что из второго следует первое. Ответить

Страница: 1 |