Here I have some basic macros for open office macro to generate wav files from a music score designed on them sheet. The principle is simple, create an array of beats in X by notes in Y, on he sheet. Then call the MakeWave macro with that array as an argument.
The system is designed to be a simple musical accompaniment for music students. It is an on going project, and likely will be complete in a day or two from Oct 1.
Updated/. As of Oct 10, a majpr re-org.
And on Oct I simplified the MakeNote routine, but have not tested it.
I broke the code into three modules,one for tones here; one for manipulating tab score, here; and one for writing out the wave file, here. (Which is this page)
I also have a wave reader, not included.
Code:
Global maxV as Single
Global minV as Single
CONST locRate = 1
CONST locVol = 2
CONST locRepeat = 3
CONST locTempo = 4
CONST locBeatCount = 5
CONST locMode = 6
CONST locCollectRate = 7
CONST locSpares = 8
CONST locFilename = 8
CONST rateBeat = 16
Global Const ratioTaper = .15
Global marginStaccato as Integer
Global testMask as Integer
Global fileName as String
Global commandLine as String
Global fileSize as Long
Global volume as Single
Global iNumber as Integer
Global sampleRate as Long
Global tempo as Integer
Global repeatCount as Integer
Global SamplesPerBeat as Integer
Global SampleCount as Long
Global BeatsPerMeasure as Integer
Global SamplesWritten as Long
Global TotalBeats as Integer
' iTones are the original arguments
Global BeatBuffer(12,2) as Byte ' beat counter and modifier
Global posFileStream as Long
' Default are dimensioned according to Calc
' Allowing substitution ofdefaults for Calc arrays
Dim DefaultArgs(1 to 10,1 to 1) as Variant
' Turn on or off various effectds
CONST AttenuateBit = &h01
CONST AlignBit = &h02
CONST StaccatoBit = &h04
CONST TestBit = &H80
Global opMode as Long
' Set default for missing arguments
sub argDef(A as variant)
y = Array(1024,10000,1,4,16,7,7,0,0,0)
for i = 1 to 10
A(i,1) = y(i-1)
next
A(locFilename,1) = "c:\users\anthony1\data4.wav"
end sub
' Never called, actually
Function InitWaveModule() as Integer
'MsgBox("Module wave init")
InitWaveModule = 0
end Function
' Main macro Entry point
' WriteScore does the work, but this entry point
' sets up default assignmentss for optional arguments
' then calls WriteScore
'
Function MakeWave(Optional args, Optional score, Optional ledger)
Dim repeat as Integer
' Set defaults for missing arguments
' Have yo have TonerCouny
if IsMissing(ledger) or not IsArray(ledger) then
ToneCount = 6 ' Using theguitar strings
else
ToneCount = ubound(ledger,1)
endif
If IsMissing(args) or not IsArray(args) then
argDef(DefaultArgs)
ArgWave(DefaultArgs)
else
ArgWave(args)
end if
If IsMissing(ledger) or not IsArray(ledger) then
toneDef(DefaultTones)
toneSet(DefaultTones)
else
toneSet(ledger)
end if
If IsMissing(score) or Not IsArray(score) Then
TotalBeats = 6
InitWave()
scoreDef(DefaultScore)
WriteScore(DefaultScore)
else
TotalBeats = ( Ubound(score,1) * Ubound(score,2) )/ToneCount
InitWave()
WriteScore(score)
end if
MakeWave = CloseWave()
end Function
' Finalize the file. Write the file size to the header.
Function CloseWave() as Integer
Dim commandLine as String
Dim samples as long
fileSize = LOF(1) ' Get the actual file size.
samples = CLng(fileSize-8)
PutOrder(CLng(fileSize-8),5,4)
Close #1 ' Close the file.
commandLine = "c:\Users\anthony1\sounder " + fileName
msgbox "Play Chunk Size: "+str(samples) + " Beats: " + str(TotalBeats)
Shell(commandLine,2)
CloseWave = 9
end Function
' initialize Wave parameters
Function InitWave() as Integer
Dim byteRate as Long
Dim bitSize as Integer
Dim numChannels as Integer
' Set up our parameters
bitSize = 16 ' Bit Size is 16 (CD-Quality).
numChannels = 2 ' Stereo mode (2-channel).
' We're going to make a 1 second sample.
fileSize = 0 ' Just set it to zero for now.
iNumber = FreeFile
testIndex =0
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),5,4)
Put #iNumber, 9, "WAVE" ' Mark it as type "WAVE"
Put #iNumber, 13, "fmt " ' Mark the format section.
PutOrder(CLng(16),17,4) ' size of header, always 16
PutOrder(CLng(1),21,2) 'Wave type PCM
PutOrder(CLng(2),23,2) ' two channels
ShowHex(sampleRate)
PutOrder(CLng(sampleRate),25,4)
byteRate = sampleRate * 4
PutOrder(CLng(byteRate),29,4)
PutOrder(CLng(4),33,2)
PutOrder(CLng(16),35,2)
Put #iNumber, 37, "data" ' "data" marker
SampleCount = SamplesPerBeat * TotalBeats
PutOrder( CLng(SampleCount*4),41,4) ' Sound sample, two byte, two channels
posFileStream = 45 'Follows header, plus Microsoft counts starting at 1
InitWave=9
end Function
' Accept an array of arguments from the spreadsheet
Function ArgWave(x as Variant)
Dim i As Integer
Dim k As Integer
Dim dr as Single
Dim dt as Single
Dim dk as Single
Dim mask as Long
Dim a2, b2, c2 as String
maxV =0
sampleRate = x(locRate,1)
volume = clng(x(locVol, 1))
tempo = x(locTempo,1)
opMode = x(locMode,1)
fileName = x(locFilename,1)
SamplesPerBeat = sampleRate/tempo
marginStaccato = SamplesPerBeat * (1.0-ratioTaper)
repeatCount = x(locRepeat,1)
BeatsPerMeasure = x(locBeatCount,1)
testMask = x(locCollectRate,1)
patternInit()
argWave = 9
end Function
Function WriteScore( Optional score) as Integer
Dim val as Single
Dim sum as Single
Dim beat as Integer
Dim iRow As Integer
Dim iCol As Integer
Dim k as Integer
Dim i as Integer
Dim repeat as Integer
Dim ScoreRow as Integer
Dim ScoreColumn as Integer
Dim current as Integer
Dim hits as Integer
Dim count as Integer
Dim phase as Single
Dim cNote as Byte
Dim MeasuresAcross as Integer
Dim LedgersDown as Integer
Dim temp(12) as String
' The score sheet is a lis of measure across and down,
' the composer can ros and ros of musice ledger, each ledger
' having the numbe rosw equal to his tone set
' And all that is subject to a repeat couny
' The Measures across is not needed at the moment as there are
' no operators defined at the measure level
' But I leave it in for later
MeasuresAcross = (uBound(score,2)-lBound(score,2) + 1)/BeatsPerMeasure
if measuresAcross = 0 then
measuresAcross = 1
BeatsPerMeasure = uBound(score,2)-lBound(score,2) + 1
end if
LedgersDown = (uBound(score,1)-lBound(score,2) + 1)/ToneCount
For repeat = 0 to repeatCount-1
For k =0 to LedgersDown-1
For m = 0 to MeasuresAcross-1
' For each beat in the measure
for iCol = 0 to BeatsPerMeasure -1
'For each note in the current beat
ScoreColumn = iCol + m * BeatsPerMeasure + 1
'for i = 0 to 10
' temp(i) = score(i+1 + k * ToneCount, ScoreColumn)
'next
For iRow = 0 to ToneCount -1
ScoreRow = iRow + k * ToneCount + 1
MakeNote(score(ScoreRow,ScoreColumn),iRow)
Next
' Write the beat out to file
for count = 0 to SamplesPerBeat-1
sum = 0.0
hits =0
for iRow = 0 to ToneCount -1
cNote = BeatBuffer(iRow,0)
If cNote > 0 Then
hits = hits + 1
val = ValPhase(iRow)
if opMode and StaccatoBit and cNote = 1 then
val = Staccato(val,count)
end if
else
val = 0
end If
sum = sum + val
Next 'row
' Now equalize for the number of tones to eliminate clipping
if(opMode and AttenuateBit) then sum = Attenuate(sum,hits)
SamplesWritten = SamplesWritten + pcmWord(volume*sum)
Next ' each sample
' Clean up beat buffer
for iRow = 0 to ToneCount -1
if BeatBuffer(iRow,0) > 0 then
BeatBuffer(iRow,0) = BeatBuffer(iRow,0)-1 'xxx
endif
BeatBuffer(iRow,1) = 0 'Modifier
Next 'each tone
Next ' Each beat in the measure
Next ' each measure acrosds
Next 'Set of Ledgers down the score
Next ' each repeat
End Function
' Termination of a note, this can become a score symbol
' Simple algorithm, take it to zero in eight samples after the termination point
Function Staccato(val as Single, sample as Integer)
Dim margin as Integer
margin = sample - marginStaccato
if margin > 8 then
val = 0
else
if margin > 6 then
val = val /2
else
if margin > 4 then
val = val/1.5
else
if margin > 2 then val = val /1.2
endif
endif
endif
Staccato = val
end Function
Function attenuate(val as Single, num as Integer) as Single
Dim temp as Single
CONST maxPCM = 32768
Attenuate =val
if num = 1 then
Attenuate = val
elseif num = 2 then
Attenuate = val * .75
elseif num = 3 then
Attenuate = val * .5
elseif num = 4 then
Attenuate = val * .3
elseif num > 4 then
Attenuate=val * .2
end if
if(val > maxV) then
maxV = val
'msgbox str(val) + " " +str(Attenuate)
elseif (val < minV) then
minV = val
'msgbox str(val) + " " +str(Attenuate)
end if
End Function
'
' Every cell from the score sheet goes through here
' The routine finds the beat count and relative pitch
' and handles both of those in the
' on a Per column basis, it fixes the pitch buffer and
' beat buffer. The beat counter remains in the bea buffer
' and is counted down over the next few columsn until
' it is zero. Meanwhile, it emits tone.
' The pitchbuffer is set, once per column
'
'Const beatString = "eq h w "
Const beatString = "qh__w____"
Sub MakeNote(note as String, row as Integer) as Integer
Dim k as Integer
Dim beat as Integer
Dim offset as Integer
Dim modifier as Integer
Dim s as string
k =1
beat = InStr(beatString, lcase(Mid (note,k, 1)))
k = k + 1
if beat > 0 then
if Mid(note,k) = "." then
beat = beat + beat/2 ' allow dotted notes
k = k + 1
end if
s = Mid (note,k, 1)
offset = Val(s)
if "0" <= s <= "9" then k = k + 1 ' If the note had a one digit step value
if offset > (stepsGet()-1) then offset = stepsGet()-1 ' maximum steps is currently 6
' modifier not used now
'BeatBuffer(row,1) = Asc(Mid (note,k, 1))
BeatBuffer(row,0) = beat
end if
MakeNote = beat
currentDeltas(row) = iDeltas(row,offSet)
End Sub
'-------------------------
' pack a pcm value identically into two channels
Function pcmWord(val as Single)
Dim upper as Byte
Dim lower as Byte
Dim count as Integer
Dim i as Long
Dim pos as Long
pos = posFileStream
i = clng(val)
lower = &Hff and i
upper = (&Hff00 And i)/256
put #iNumber,pos+1,lower ' Basic starts counting at 1
put #iNumber,pos+2,upper
put #iNumber,pos+3,lower
put #iNumber,pos+4,upper
posFileStream = posFileStream+4
pcmWord = 2
end Function
' 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,b(i) ' Basic starts counting at 1
Next
end Sub
Function GetElement(x,optional i,optional j)
select case x
case "Center"
GetElement = Center
case "Notes"
GetElement = LedgerSequence(i)
case "SampleRate"
GetElement = sampleRate
case "SamplesPerBeat"
GetElement = SamplesperBeat
case "LedgerCount"
GetElement = ToneCount
case "FilerSize"
GetElement= fileSize
Case "SampleCount"
GetElement = SampleCount
case "Scale"
GetElement = mid(scale,i,1)
case "Ratio"
GetElement = MagicRatio
end select
end function
No comments:
Post a Comment