3 hours ago
Hi. During my work I created this interesting sound generator, so I added a save option for you. It is a simple program with the option to save the output to a WAV 16bit mono file.
Code: (Select All)
Const PI = 3.14159265359
' Parametry signálu Signal parameters
Dim Shared Frequency As Single: Frequency = 440
Dim Shared SampleRate As Single: SampleRate = _SndRate
Dim Shared Duration As Single: Duration = 2
' Parametry efektu Effects parameters
Dim Shared DistortionLevel As Single: DistortionLevel = 0.8
Dim Shared HarmonicStrength As Single: HarmonicStrength = 0.3
Dim Shared VibratoDepth As Single: VibratoDepth = 10
Dim Shared VibratoRate As Single: VibratoRate = 6
' Generování zvuku Generate Sound
Dim SAMPLES As Long: SAMPLES = SampleRate * Duration
Dim Shared Signal(SAMPLES - 1) As Single
For f = 1 To 1000
begin:
Frequency = 50 + 300 * Rnd
For j = 0 To SAMPLES - 1
Signal(j) = 0
Next
GenerateGuitarTone Signal()
Duration = 1 + Rnd * 3
DistortionLevel = .6 + (1 + Rnd * 3) / 10
VibratoDepth = 15 + Rnd * 40
VibratoRate = 1 + Rnd * 150
start:
' P°ehrßnÝ zvuku Playing the sound
For i = 0 To SAMPLES - 1
_SndRaw Signal(i), Signal(i)
Next i
Do While _SndRawLen > 0
Loop
answ:
Input "[P]lay again, [Q]uit, [N]ext, [S]ave to file"; msg$
Select Case UCase$(msg$)
Case "P": GoTo start
Case "Q": System
Case "N": GoTo begin
Case "S": To$ = _SaveFileDialog$("Save effect", _CWD$, "*.WAV", "Wavetable files")
NormalizeSignal Signal()
SndMonoSave16 Signal(), To$
GoTo answ
Case Else
GoTo answ
End Select
Next f
Sub GenerateGuitarTone (Signal() As Single)
Dim i As Long
For i = 0 To UBound(Signal)
' Základní sinusová vlna
Dim VibratoOffset As Single
VibratoOffset = VibratoDepth * Sin(2 * PI * VibratoRate * i / SampleRate)
Signal(i) = Sin(2 * PI * (Frequency + VibratoOffset) * i / SampleRate)
' Přidání harmonických složek harmonical waves
Signal(i) = Signal(i) + HarmonicStrength * Sin(2 * PI * (2 * Frequency) * i / SampleRate) ' Oktáva
Signal(i) = Signal(i) + HarmonicStrength / 2 * Sin(2 * PI * (3 * Frequency) * i / SampleRate) ' Kvinta
Signal(i) = Signal(i) + HarmonicStrength / 4 * Sin(2 * PI * (4 * Frequency) * i / SampleRate) ' Další
' Zkreslení (hard clipping)
Signal(i) = Signal(i) * (1 + DistortionLevel)
If Signal(i) > 1 Then Signal(i) = 1
If Signal(i) < -1 Then Signal(i) = -1
' Wave shaping
Signal(i) = Signal(i) + 0.5 * Signal(i) ^ 2 - 0.2 * Signal(i) ^ 3
' Tlumení damping
Signal(i) = Signal(i) * (1 - i / UBound(Signal))
Next i
End Sub
'---------------------------------------------------------------------
Sub NormalizeSignal (arr() As Single)
Dim maxVal As Single
Dim i As Long
' Najít maximální absolutní hodnotu Find maximal value in signal
maxVal = 0
For i = LBound(arr) To UBound(arr)
If Abs(arr(i)) > maxVal Then maxVal = Abs(arr(i))
Next
' Pokud je maximální hodnota větší než 1.0, normalizovat signál if maximal value is bigger than 1, normalize signal
If maxVal > 1.0 Then
For i = LBound(arr) To UBound(arr)
arr(i) = arr(i) / maxVal
Next
End If
End Sub
Sub SndMonoSave16 (arr() As Single, file As String)
Type head16
chunk As String * 4 ' 4 bytes (RIFF)
size As _Unsigned Long ' 4 bytes (file size) velikost souboru
fomat As String * 4 ' 4 bytes (WAVE)
sub1 As String * 4 ' 4 bytes (fmt )
subchunksize As Long ' 4 bytes (lo / hi), $00000010 for PCM audio
format As Integer ' 2 bytes (0001 = standard PCM, 0101 = IBM mu-law, 0102 = IBM a-law, 0103 = IBM AVC ADPCM)
channels As Integer ' 2 bytes (1 = mono, 2 = stereo)
rate As Long ' 4 bytes (sample rate, standard is 44100)
ByteRate As Long ' 4 bytes (= sample rate * number of channels * (bits per channel /8))
Block As Integer ' 2 bytes (block align = number of channels * bits per sample /8)
Bits As Integer ' 2 bytes (bits per sample. 8 = 8, 16 = 16)
subchunk2 As String * 4 ' 4 bytes ("data") contains begin audio samples
lenght As _Unsigned Long ' 4 bytes Data block size
End Type ' 44 bytes total
Dim H16 As head16
ch = FreeFile
H16.chunk = "RIFF"
H16.size = 44 + UBound(arr) * 2 ' 2 byte (integer)
H16.fomat = "WAVE"
H16.sub1 = "fmt "
H16.subchunksize = 16
H16.format = 1
H16.channels = 1
H16.rate = _SndRate
H16.Bits = 16
H16.ByteRate = (_SndRate * 1 * H16.Bits) / 8
H16.Block = (1 * H16.Bits) / 8
H16.subchunk2 = "data"
H16.lenght = UBound(arr) * 2 ' 2 Byte
If _FileExists(file$) Then Kill file$
Open file$ For Binary As #ch
Put #ch, , H16
Dim Value As Integer
For s = 0 To UBound(arr)
Value = arr(s) * 32767
Put #ch, , Value
Next
Close ch
_SndPlayFile file$
End Sub
Function ConvertOffset&& (value As _Offset)
$Checking:Off
Dim m As _MEM 'Define a memblock
m = _Mem(value) 'Point it to use value
$If 64BIT Then
'On 64 bit OSes, an OFFSET is 8 bytes in size. We can put it directly into an Integer64
_MEMGET m, m.OFFSET, ConvertOffset&& 'Get the contents of the memblock and put the values there directly into ConvertOffset&&
$Else
'However, on 32 bit OSes, an OFFSET is only 4 bytes. We need to put it into a LONG variable first
_MemGet m, m.OFFSET, temp& 'Like this
ConvertOffset&& = temp& 'And then assign that long value to ConvertOffset&&
$End If
_MemFree m 'Free the memblock
$Checking:On
End Function
