Write a wav file in basic

Odd of me to crank out a basic macro, but I engineered the musical notes on my spread sheet and needed to play tones and chords. So I cranked a wave macro with stolen code, author acknowledged.  If I stick to pulse code modulation then adding wave file algebra is simple, I can add or remove tones from a single wave file.  So, the spreadsheet inits with the time interval, sample rate and volume.  Everything else is mandated to 16 bit stereo PCM. Hence, once the file is inited, I can re-open and do arithmetic on the data, leaving the header alone, simple. Let's me turn my spreadsheet into a music instrument.


Global sampleRate as Long
Global numSeconds as Integer
Global fileName as String
Global commandLinee as String
Global fileSize as Long
Global volume as Integer
Global iNumber as Integer
Global iTunes(8) as Integer
Global iPhases(8) as Single
Global iDeltas(8) as Single
Global pcmPattern(256) as Single
' index an argument array
CONST locRate = 1
CONST    locVol = 2
CONST    locTone = 3
CONST    locSeconds = 4
CONST locTunes = 5
Sub t
Dim x(1 to 8,1 to 2) as Integer
'  Simulate the init call from calc
x(locRate,1) = 22050
x(locVol,1) = 4096
x(locTone,1) = 300
x(locSeconds,1) = 1
x(locTunes,1) = 300
x(locTunes+1,1) = 0
argWave(x)
msgbox CurDir
'InitWave(4096,1,1)

End Sub

Function WriteWave( tone as Integer) as Integer

Dim dataPos as Long
Dim headerLength as Integer
Dim totalSamples as Long
Dim iVar As Integer

Dim dt as Single
Dim sec as Single
Dim radians as Single
Dim temp as Single



' headerLength is the length of the header.  It is used for offsetting
' the data position.
headerLength = 44

' Determine the total number of samples
totalSamples = sampleRate * numSeconds

' Populate
PutOrder(CLng(totalSamples * 4),headerLength-4,4)

For dataPos = 0 to totalSamples-1
temp = signalSum() * volume
'Two bytes per channel

  PutOrder(CLng(temp),4*dataPos+headerLength,2)
  PutOrder(CLng(temp),4*dataPos+headerLength+2,2)
Next

' Finalize the file.  Write the file size to the header.
fileSize = LOF(1)               ' Get the actual file size.

PutOrder(CLng(fileSize-8),4,4)

Close #1 ' Close the file.
WriteWave=9
 End Function

 ' Create file, initialize PCM parameters
Function InitWave(vol as Integer,seconds as Integer,rate as Integer) as Integer
Dim byteRate as Long
Dim bitSize as Integer
Dim numChannels as Integer
' Set up our parameters
sampleRate = 22050        ' CD-Quality Sound.
bitSize = 16              ' Bit Size is 16 (CD-Quality).
numChannels = 2           ' Stereo mode (2-channel).
numSeconds = seconds            ' We're going to make a 1 second sample.
fileSize = 0              ' Just set it to zero for now.
iNumber = FreeFile
volume = vol
fileName="c:\Users\anthony1\data4.wav"
if FileExists(fileName) then Kill fileName
' Open the file.  This will fail if the file exists.
Open fileName For Binary Access  Write As #iNumber
'Open fileName For Binary Access Write As #1
' Write the header
Put #iNumber, 1,  "RIFF"        ' RIFF marker
PutOrder(Clng(0),4,4)
Put #iNumber, 9,  "WAVE"        ' Mark it as type "WAVE"
Put #iNumber, 13, "fmt "        ' Mark the format section.
PutOrder(CLng(16),16,4)


PutOrder(CLng(1),20,2)  'Wave type PCM
PutOrder(CLng(2),22,2) ' two channels
PutOrder(CLng(sampleRate),24,4)
byteRate = sampleRate * 4
ShowHex(CLng(byteRate))
PutOrder(CLng(byteRate),28,4)


PutOrder(CLng(4),32,2)
PutOrder(CLng(16),34,2)
Put #iNumber, 37, "data"        ' "data" marker
InitWave=9
end Function

Sub  Operate(iVar as Integer)
Dim val as Integer
val = GetOrder(12)
Select Case iVar
Case 1 To 5
Print "Number from 1 to 5"
Case 6, 7, 8
Print "Number from 6 to 8"
Case 8 To 10
Print "Greater than 8"
Case Else
Print "Out of range 1 to 10"
End Select
End Sub

' Reverses the order, from system order to wave format order
Sub PutOrder(val as Long,pos as Long,size as Integer)
Dim i As Integer
Dim b(8) As Byte
Dim mask as Integer
Dim temp as Long
temp = val
mask=255
For i = 0 to size-1
'ShowHex(val)
b(i) = CByte((CLng(255) And val))
val = CLng(&Hffffff00 And val)/256
'ShowHex(b(i))
put #iNumber,pos+i+1,b(i) ' Basic starts counting at 1

Next
end Sub


' Accept an array of arguments from yhe spreadsheet            
Function argWave(Optional x)

  Dim iRow As Integer
  Dim iCol As Integer
  Dim dr as Single
  Dim dt as Single
     arrayArgs = 0

  If NOT IsMissing(x) Then
    If NOT IsArray(x) Then
      arrayArgs = 1
    Else
    sampleRate = x(locRate,1)
    volume = x(locVol, 1)
    tone = x(locTone,1)
    numSeconds = x(locSeconds,1)
    iRow=locTunes
    iCol=0
    while (x(iRow,1) > 0)
    iTunes(iCol) = x(iRow,1)
    dt = 1/sampleRate
  dr = iTunes(iCol) *2*pi * dt
    iPhases(iCol) = dr
    iDeltas(iCol) = dr
    iRow = iRow + 1
    iCol= iCol+1
    Wend
    iTunes(iCol) = 0
    dr = 2*pi/256
    dt=0
    for iCol = 0 to 255
    pcmPattern(iCol) = sin(dt) + 1
    dt = dt + dr
    next iCol

    argWave = InitWave(volume ,numSeconds ,sampleRate )
    WriteWave(tone)
    'Shell("c:\windows\calc.exe",2)
    commandLine = "c:\Users\anthony1\sounder " + fileName
    Shell(commandLine,2)
    'start /MIN/WAIT c:\Users\anthony1\data4.wav
    'mplay32 /play /close c:\Users\anthony1\data4.wav
    'c:\Users\anthony1\sounder  c:\Users\anthony1\data4.wav
    endif
    endif
    end function
Function signalSum()
dim i as Integer
Dim k as Integer
Dim val as Single
Dim phase as Single
Dim temp as Single
val =  0
i = 0

    while iTunes(i) > 0
    phase =  iPhases(i) +iDeltas(i)
    if phase > 2*pi then phase = phase - 2*pi

    temp = ( phase / (pi *2))
        k = 250 * temp
    val =  val + pcmPattern(k)
    iPhases(i) =  phase
    i=i+1
    Wend
    signalSum = val
    end Function