03-28-2005, 07:35 PM
I changed it to use the midi functions keeling made/ported instead of the api sound call, which only worked on winxp/2k. I also added two new play commands, I and V, to control instrument and volume. See the code for more info on that.
You will also need keelings midi_acc.bi found in this thread, if you hanve't already got it.
It still only works on windows systems, but at least more broadly than before.
Code:
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'' QB PLAY command for freeBasic by RAJM 2005
'' Second edition, uses midi lib and midi functions by keeling
''' from qbasicnews.com. Without that, it would suck ;)
''
'' Supports all the original stuff, except the VARPTR$ part
''
'' Due to the midi capabilities, two new functions have been
'' added. One controls instrument, and one changes volume:
''
'' Pn - changes to instrument number n (0 - 127)
'' Vn - sets volume to n (0 - 127)
''
''''''''''
'''''
#include once "midi_acc.bi"
'outward subs
declare sub play ( playstr as string)
'internal used functions
declare sub _fbplay_internal_thread ( byval threadId as integer )
declare function _fbplay_internal_translateNote(toTranslate as string) as ubyte
declare sub _fbplay_internal_PlayNote (ByVal Note as integer, ByVal Octave as integer, _
ByVal Duration as single, ByVal Instrument as integer = 0, _
ByVal Volume as integer = 127, midiHandle as integer)
'This one should prolly have been made using pointers, but I couldnt make it work with threads and stuff.
dim shared _fbplay_internal_playstr as string
sub play (playstr as string)
dim thread_handle as integer
dim thread_count as uinteger
_fbplay_internal_playstr=trim(playstr)
thread_handle = threadcreate( @_fbplay_internal_thread, threadCount)
if thread_handle = 0 then 'thread creation failed for some reason
exit sub 'quit quitly
end if
if lcase$(left$(_fbplay_internal_playstr,2))="mf" then 'supposed to play in foreground
threadwait thread_handle 'so wait till we're done playing
end if
thread_count+=1
end sub
sub _fbplay_internal_thread ( byval threadId as integer )
CONST octave_max=10, octave_min=0, octave_mod=+3
dim tempo as uinteger
dim note_len as ubyte, note_len_mod as double
dim octave as ubyte
dim instrument as ubyte
dim volume as ubyte
dim freq as double, duration as double, idx as ubyte
dim number as string, char as string*1
dim pause_len as ubyte
dim stop_timer as double
dim midiHandle as integer
midiHandle=midiOpen
tempo = 120 'default tempo is 120 quarter notes per minute
note_len=4 'default note is a quarter note
note_len_mod=1 'as default notes play their full length
octave=4 'default octave is the 4th
instrument=0 'default instrument is acoustic grand piano |TODO: Find a instrument closer to QB's PLAY sound.
volume=127 'maximum volume is default
for p = 1 to len(_fbplay_internal_playstr)
char=lcase$(mid$(_fbplay_internal_playstr, p, 1))
select case char
'basic playing
case "n" 'plays note with next-comming number, if 0 then pause
number=""
do
p+=1
char=mid$(_fbplay_internal_playstr, p, 1)
if asc(char)>=48 and asc(char)<=57 then
number+=char
else
exit do
end if
loop
idx=val(number)
if idx=0 then 'pause
duration=60/tempo*(4/note_len)*note_len_mod/60
stop_timer=timer+duration
while timer<stop_timer: wend
else 'note
duration=1000*60/tempo*(4/note_len)*note_len_mod
tmpOctave=idx\12
tmpNote=idx-(tmpOctave*12)
_fbplay_internal_PlayNote tmpNote, tmpOctave, duration, instrument, volume, midiHandle
end if
case "a" to "g" 'plays a to g in current octave
duration=60/tempo*(4/note_len)*note_len_mod
toTranslate$=char
if lcase$(mid$(_fbplay_internal_playstr, p+1, 1))="-" then
toTranslate$+="b"
p+=1
elseif lcase$(mid$(_fbplay_internal_playstr, p+1, 1))="+" then
toTranslate$+="s"
p+=1
end if
_fbplay_internal_PlayNote _fbplay_internal_translateNote(toTranslate$), octave, duration, instrument, volume, midiHandle
case "p" 'pauses for next-comming number of quarter notes
number=""
do
p+=1
char=mid$(_fbplay_internal_playstr, p, 1)
if asc(char)>=48 and asc(char)<=57 then
number+=char
else
exit do
end if
loop
pause_len=val(number)
duration=60/tempo*pause_len*note_len_mod/60
stop_timer=timer+duration
while timer<stop_timer: wend
'octave handling
case ">" 'up one octave
if octave<octave_max then octave=octave+1
case "<" 'down one octave
if octave>octave_min then octave=octave-1
case "o" 'changes octave to next-comming number
p+=1
char=mid$(_fbplay_internal_playstr, p, 1)
octave=val(char)
'play control
case "t" 'changes tempo (quarter notes per minute)
number=""
do
p+=1
char=mid$(_fbplay_internal_playstr, p, 1)
if asc(char)>=48 and asc(char)<=57 then
number+=char
else
exit do
end if
loop
tempo=val(number)
case "l" 'changes note length (1=full note, 4=quarter note, 8 eigth(?) note aso)
p+=1
char=mid$(_fbplay_internal_playstr, p, 1)
note_len=val(char)
case "m" 'MS makes note last 3/4, MN is 7/8 and ML sets to normal length
p+=1
char=lcase$(mid$(_fbplay_internal_playstr, p, 1))
if char="s" then note_len_mod=3/4
if char="n" then note_len_mod=7/8
if char="l" then note_len_mod=1
'new midi fucntions
case "i"
number=""
do
p+=1
char=mid$(_fbplay_internal_playstr, p, 1)
if asc(char)>=48 and asc(char)<=57 then
number+=char
else
exit do
end if
loop
instrument=val(number)
case "v"
number=""
do
p+=1
char=mid$(_fbplay_internal_playstr, p, 1)
if asc(char)>=48 and asc(char)<=57 then
number+=char
else
exit do
end if
loop
volume=val(number)
end select
next p
midiClose midiHandle
end sub
function _fbplay_internal_translateNote(toTranslate as string) as ubyte
select case toTranslate
case "c" : translated = 0
case "cs" : translated = 1
case "db" : translated = 1
case "d" : translated = 2
case "ds" : translated = 3
case "eb" : translated = 3
case "e" : translated = 4
case "fb" : translated = 4
case "f" : translated = 5
case "es" : translated = 5
case "fs" : translated = 6
case "gb" : translated = 6
case "g" : translated = 7
case "gs" : translated = 8
case "ab" : translated = 8
case "a" : translated = 9
case "as" : translated = 10
case "bb" : translated = 10
case "b" : translated = 11
case "cb" : translated = 11
end select
_fbplay_internal_translateNote = translated
end function
sub _fbplay_internal_PlayNote (ByVal Note as integer, ByVal Octave as integer, _
ByVal Duration as single, ByVal Instrument as integer = 0, _
ByVal Volume as integer = 127, midiHandle as integer)
dim t as single
MidiSetInstrument midiHandle, Instrument
MidiNoteOn midiHandle,Note,Octave, Volume
t = timer + Duration
do while t > timer
sleep 10
loop
MidiNoteOff midiHandle, Note, Octave
end sub
''''''''''''''''''''''''''''''''''''''''''''''
'' Test proggy
'''''
CONTROL$="MB "
'CONTROL$="MF " 'unrem to play in foreground
LISTEN$ = "V127 I25 T180 O2 P2 P8 L8 GGG L2 E-" '<-- example from qb help (modified to show midi stuff)
FATE$ = "P24 P8 L8 V90 I20 FFF L2 D"
PLAY CONTROL$ + LISTEN$ + FATE$
print "back"
sleepYou will also need keelings midi_acc.bi found in this thread, if you hanve't already got it.
It still only works on windows systems, but at least more broadly than before.
url=http://www.copy-pasta.com]CopyPasta[/url] - FilePasta
