Option Explicit
Private Type tWAVEFORMATEX
wFormatTag As Integer
nChannels As Integer
nSamplesPerSec As Long
nAvgBytesPerSec As Long
nBlockAlign As Integer
wBitsPerSample As Integer
cbSize As Integer
ExtraData(1 To 32) As Byte ' makes the structure 50 bytes long
End Type
Private Type FileHeader
lRiff As Long
lFileSize As Long
lWave As Long
lFormat As Long
lFormatLength As Long
End Type
Private Type WaveFormat
wFormatTag As Integer
nChannels As Integer
nSamplesPerSec As Long
nAvgBytesPerSec As Long
nBlockAlign As Integer
wBitsPerSample As Integer
End Type
Private Type ChunkHeader
lType As Long
lLen As Long
End Type
Private Sub Form_Load()
Dim Buff(0 To 44100 * 5) As Integer ' 5 Seconds of sound
GenerateTone 440, Buff, 1, , , 44100 * 0.2
AddEcho Buff, 44100 * 0.35, , 1.5
SaveWaveFile "C:\test_Wave_1.wav", Buff
Erase Buff
GenerateTone 440, Buff, 1, , , 44100 * 0.3
AddEcho Buff, 44100 * 0.6, , 1.5
SaveWaveFile "C:\test_Wave_2.wav", Buff
Erase Buff
GenerateDualTone 440, 438.6, Buff, 0.5, 0.5, , , 44100 * 0.35
AddEcho Buff, 44100 * 0.45, , 1.1
SaveWaveFile "C:\test_Wave_3.wav", Buff
Erase Buff
GenerateDualTone 440, 1000, Buff, 0.5, 0.5, , , 44100 * 0.35
AddEcho Buff, 44100 * 0.1, , 1.1
AddEcho Buff, 44100 * 0.55, , 1.4
SaveWaveFile "C:\test_Wave_4.wav", Buff
Erase Buff
GenerateDualTone 400, 700, Buff, 0.5, 0.5, , , 44100 * 0.4
AddEcho Buff, 44100 * 0.5, , 1.1
GenerateDualTone 500, 800, Buff, 0.5, 0.5, , 10000, 44100 * 0.4
AddEcho Buff, 44100 * 0.45, , 1.3
SaveWaveFile "C:\test_Wave_5.wav", Buff
End Sub
Private Sub GenerateTone(ByVal Frequency As Single, IntBuff() As Integer, Optional Amplitude As Single = 1, Optional SamplesPerSec As Long = 44100, Optional Startpos As Long = 0, Optional Length As Long = -1)
Dim K As Long, V1 As Double
Const PI As Double = 3.14159265358979
V1 = SamplesPerSec / (PI * 2 * Frequency)
If Length = -1 Then Length = UBound(IntBuff) - Startpos
For K = Startpos To Startpos + Length
IntBuff(K) = CInt(Fix(Sin(K / V1) * (32766.5 * Amplitude)))
Next K
End Sub
Private Sub GenerateDualTone(ByVal Frequency1 As Single, ByVal Frequency2 As Single, IntBuff() As Integer, Optional Amplitude1 As Single = 1, Optional Amplitude2 As Single = 1, Optional SamplesPerSec As Long = 44100, Optional Startpos As Long = 0, Optional Length As Long = -1)
Dim K As Long, V1 As Double, V2 As Double, Sample As Long
Const PI As Double = 3.14159265358979
V1 = SamplesPerSec / (PI * 2 * Frequency1)
V2 = SamplesPerSec / (PI * 2 * Frequency2)
If Length = -1 Then Length = UBound(IntBuff) - Startpos
For K = Startpos To Startpos + Length
Sample = Sin(K / V1) * (32766.5 * Amplitude1) + Sin(K / V2) * (32766.5 * Amplitude2)
If Sample < -32767 Then Sample = -32767
If Sample > 32767 Then Sample = 32767
IntBuff(K) = Sample
Next K
End Sub
Private Sub AddEcho(IntBuff() As Integer, ByVal Delay As Long, Optional Startpos As Long = 0, Optional ByVal Strength As Single = 1)
Dim K As Long, NewSample As Long
For K = Startpos + Delay To UBound(IntBuff)
NewSample = Fix((IntBuff(K - Delay) / 2 * Strength) + IntBuff(K) / 2)
If NewSample < -32767 Then NewSample = -32767
If NewSample > 32767 Then NewSample = 32767
IntBuff(K) = NewSample
Next K
End Sub
Private Sub SaveWaveFile(ByVal WaveFileName As String, ByRef Buffer() As Integer, Optional SamplesPerSec As Long = 44100)
Dim WF As tWAVEFORMATEX
WF.wFormatTag = 1 'WAVE_FORMAT_PCM
WF.nChannels = 1
WF.wBitsPerSample = 16
WF.nSamplesPerSec = SamplesPerSec
WF.nBlockAlign = (WF.wBitsPerSample * WF.nChannels) \ 8
WF.nAvgBytesPerSec = WF.nSamplesPerSec * WF.nBlockAlign
Open WaveFileName For Binary Access Write Lock Write As #1
WaveWriteHeader 1, WF
Put #1, , Buffer
WaveWriteHeaderEnd 1
Close #1
End Sub
Private Sub WaveWriteHeader(ByVal OutFileNum As Integer, WaveFmt As tWAVEFORMATEX)
Dim header As FileHeader
Dim HdrFormat As WaveFormat
Dim chunk As ChunkHeader
With header
.lRiff = &H46464952 ' "RIFF"
.lFileSize = 0
.lWave = &H45564157 ' "WAVE"
.lFormat = &H20746D66 ' "fmt "
.lFormatLength = Len(HdrFormat)
End With
With HdrFormat
.wFormatTag = WaveFmt.wFormatTag
.nChannels = WaveFmt.nChannels
.nSamplesPerSec = WaveFmt.nSamplesPerSec
.nAvgBytesPerSec = WaveFmt.nAvgBytesPerSec
.nBlockAlign = WaveFmt.nBlockAlign
.wBitsPerSample = WaveFmt.wBitsPerSample
End With
chunk.lType = &H61746164 ' "data"
chunk.lLen = 0
Put #OutFileNum, 1, header
Put #OutFileNum, , HdrFormat
Put #OutFileNum, , chunk
End Sub
Private Sub WaveWriteHeaderEnd(ByVal OutFileNum As Integer)
Dim header As FileHeader
Dim HdrFormat As WaveFormat
Dim chunk As ChunkHeader
Dim Lng As Long
Lng = LOF(OutFileNum)
Put #OutFileNum, 5, Lng
Lng = LOF(OutFileNum) - (Len(header) + Len(HdrFormat) + Len(chunk))
Put #OutFileNum, Len(header) + Len(HdrFormat) + 5, Lng
End Sub