02-21-2026, 11:30 PM
(This post was last modified: 02-22-2026, 12:03 AM by PhilOfPerth.)
This is a fairly simple programme that allows the user to compose tunes, using the volume, tempo, note-length and tone features provided in QB64PE.
Code: (Select All)
Common Shared LineNumum, LN$, CPR, MX, MY, Tune$, Tunes$(), Octave, Length, Tempo, Volume, NT, NT$
Common Shared TN$, OldTune$, LastOp$, Remove$
SW = 1040: sh = 720
Screen _NewImage(SW, sh, 32)
SetFont: f& = _LoadFont("C:\WINDOWS\fonts\courbd.ttf", 20, "monospace"): _Font f&
CPR = SW / _PrintWidth("X") ' chars per row for this screen setting
_ScreenMove (_DesktopWidth - SW) / 2, 100
Color _RGB(255, 255, 255), _RGB(64, 64, 0): Cls
'Kill "TuneDir": Kill "Tunes"
If Not _FileExists("TuneDir") Or Not _FileExists("Tunes") Then
Open "TuneDir" For Output As #1: Open "Tunes" For Output As #2 ' create new files if missing
Close
End If
'Kill "TUNEDIR": Kill "TUNES" ' delete all tunes for testing functions
Instructions
Octave = 3: Length = 4: Tempo = 125: Volume = 50
Dim Tunes$(9)
Box1$ = "r143d35l143u35r47nd35r63nd35": Box2$ = "r83d35l85u35"
Tune$ = "v0o3l4t120cv50"
Play Tune$ ' set defaults
Start:
Yellow: Locate 2, 16: Print "OCTAVE"; Tab(31); "1/LENGTH"; Tab(47); "TEMPO"; Tab(61); "VOLUME"
Yellow: Locate 4, 15: Print "- ";: White: Print LTrim$(Str$(Octave));: Yellow: Print " +"
Yellow: Locate 4, 29: Print "- ";: White: Print LTrim$(Str$(Length));: Yellow: Print " +"
Yellow: Locate 4, 45: Print "- ";: White: Print LTrim$(Str$(Tempo));: Yellow: Print " +"
Yellow: Locate 4, 60: Print "- ";: White: Print LTrim$(Str$(Volume));: Yellow: Print " +"
Locate 7, 16: Print "NEW"
Locate 7, 26: Print "BACK"
Locate 7, 40: Print "PLAY"
Locate 7, 53: Print "LOAD"
Locate 7, 64: Print "SAVE"
PSet (165, 50)
Draw Box1$
PSet (350, 50)
Draw Box1$
PSet (555, 50)
Draw Box1$
PSet (748, 50)
Draw Box1$
PSet (170, 110)
Draw Box2$
PSet (310, 110)
Draw Box2$
PSet (490, 110)
Draw Box2$
PSet (660, 110)
Draw Box2$
PSet (805, 110)
Draw Box2$
whitekeys:
For a = 292 To 682 Step 65
Line (a, 505)-(a + 60, 635), _RGB(255, 255, 255), BF
Next
blackkeys:
Line (332, 505)-(372, 560), _RGB(32, 32, 0), BF
Line (397, 505)-(437, 560), _RGB(32, 32, 0), BF
Line (527, 505)-(567, 560), _RGB(32, 32, 0), BF
Line (592, 505)-(631, 560), _RGB(32, 32, 0), BF
Line (657, 505)-(696, 560), _RGB(32, 32, 0), BF
KeyLabels:
Centre "C# Eb F# Ab Bb ", 25
Centre "C D E F G A B", 33
Tune$ = ""
Do
DisplayTune
Do
i = _MouseInput
Loop Until _MouseButton(1)
MX = _MouseX: MY = _MouseY
DealWithMouse
Do
i = _MouseInput
Loop Until Not _MouseButton(1)
Loop
Sub DealWithMouse
Select Case MY
Case 50 To 85 ' <--------------------- octave, length, tempo, volume
White: Locate 8, 1
Select Case MX ' get the mouse horiz position
Case 164 To 204 ' Octave -
If Octave > 0 Then ' don't do anything if at octave 0
If LastOp$ = "O" Then
Tune$ = Left$(Tune$, Len(Tune$) - 2)
End If
Octave = Octave - 1
Locate 4, 19: White: Print LTrim$(Str$(Octave)) + " "
Tune$ = Tune$ + "O" + LTrim$(Str$(Octave))
LastOp$ = "O"
End If
Case 267 To 307 ' Octave +
If Octave < 6 Then ' don't do anything if at octave 6
If LastOp$ = "O" Then
Tune$ = Left$(Tune$, Len(Tune$) - 2)
End If
Octave = Octave + 1
Locate 4, 19: White: Print LTrim$(Str$(Octave)) + " "
Tune$ = Tune$ + "O" + LTrim$(Str$(Octave))
LastOp$ = "O"
End If
Case 352 To 392 ' Length -
If Length > 1 Then
If LastOp$ = "L" Then Tune$ = Left$(Tune$, Len(Tune$) - Len((Str$(Length))))
Length = Length / 2
Locate 4, 33: Print Space$(3): Locate 4, 33: White: Print LTrim$(Str$(Length)) + " "
Tune$ = Tune$ + "L" + LTrim$(Str$(Length))
LastOp$ = "L"
End If
Case 455 To 495 ' Length +
If Length < 64 Then
If LastOp$ = "L" Then Tune$ = Left$(Tune$, Len(Tune$) - Len(Str$(Length)))
Length = Length * 2
Locate 4, 33: Print Space$(3): Locate 4, 33:: White: Print LTrim$(Str$(Length)) + " "
Tune$ = Tune$ + "L" + LTrim$(Str$(Length))
LastOp$ = "L"
End If
Case 555 To 595 ' Tempo -
If Tempo > 40 Then ' only if not at maximum
If LastOp$ = "T" Then Tune$ = Left$(Tune$, Len(Tune$) - Len(Str$(Tempo)))
Tempo = Tempo - 10
Locate 4, 48: White: Print LTrim$(Str$(Tempo)) + " "
Tune$ = Tune$ + "T" + LTrim$(Str$(Tempo))
LastOp$ = "T"
End If
Case 658 To 698 ' tempo +
If Tempo < 246 Then ' only if not at maximum
If LastOp$ = "T" Then Tune$ = Left$(Tune$, Len(Tune$) - Len(Str$(Tempo)))
Tempo = Tempo + 10
Locate 4, 48: White: Print LTrim$(Str$(Tempo)) + " "
Tune$ = Tune$ + "T" + LTrim$(Str$(Tempo))
LastOp$ = "T"
End If
Case 750 To 790 ' Volume-
If Volume > 4 Then
If LastOp$ = "V" Then Tune$ = Left$(Tune$, Len(Tune$) - Len(Str$(Volume)))
Volume = Volume - 5
Locate 4, 63: White: Print Space$(4): Locate 4, 63: Print LTrim$(Str$(Volume))
Tune$ = Tune$ + "V" + LTrim$(Str$(Volume))
LastOp$ = "V"
End If
Case 853 To 893 ' Volume+
If Volume < 96 Then
If LastOp$ = "V" Then Tune$ = Left$(Tune$, Len(Tune$) - Len(Str$(Volume)))
Volume = Volume + 5
Locate 4, 63: White: Print Space$(4): Locate 4, 63: Print LTrim$(Str$(Volume))
Tune$ = Tune$ + "V" + LTrim$(Str$(Volume))
LastOp$ = "V"
End If
End Select
Case 110 To 145 ' <--------------------- New, Back, Play, Save
Play "o3l4t125v50" ' ' reset defaults
LastOp$ = ""
Select Case MX
Case 170 To 253 ' new tune
Tune$ = "" ' delete tune string
Octave = 3: Length = 4: Tempo = 125: Volume = 50 ' reset defaults
For a = 9 To 20: Locate a, 1: Print Space$(80);: Next ' erase old tune display
Locate 4, 19: White: Print LTrim$(Str$(Octave))
Locate 4, 33: White: Print " ": Locate 4, 33: Print LTrim$(Str$(Length))
Locate 4, 48: White: Print " ": Locate 4, 48: Print LTrim$(Str$(Tempo))
Locate 4, 63: White: Print " ": Locate 4, 63: Print LTrim$(Str$(Volume))
Case 490 To 573 ' play tune
Play "v0o3l4t120cv50" ' ensure default settings are applied first
Play Tune$
Case 660 To 743 ' load tune
NT = 0
Open "TuneDir" For Input As #1
If LOF(1) < 2 Then Play bad$: Centre "No tunes saved yet, sorry", 10: Sleep 1: WIPE "10": Close: Exit Sub
Play "v0o3l4t120cv50"
WipeTuneDisplay
Locate 10, 1
While Not EOF(1)
NT = NT + 1
Input #1, Tune$
Print Tab(35); NT; Tab(40); Tune$
Wend
Close
Centre "Number of the tune to load ", 22 ' invite number selection
Locate 22, 53: Input TN$
If Val(TN$) > NT Or Val(TN$) = 0 Then Exit Sub
TN = Val(TN$)
Open "tunes" For Input As #1
For a = 1 To TN: Input #1, Tune$: Next: Close
Locate 18, 60
_KeyClear
WipeTuneDisplay ' tune may be shorter, so erase previous tune display
WIPE "1822": Centre "The requested tune is loaded", 18: Sleep 1
l = Len(Tune$)
Case 805 To 888 ' save tune
If Tune$ = "" Then Exit Sub
Cls: Close
NT = 0
Yellow: Centre "Existing Tunes:", 12: White
Open "TuneDir" For Input As #1 ' get Tunes list
While Not EOF(1)
Input #1, OldTune$
NT = NT + 1
Print Tab(35); NT; Tab(40); OldTune$
Wend
Close
_KeyClear
If NT > 9 Then
Yellow: Centre "No more room; tune to be replaced (1 to 10) ", 24
White: Locate 24, 60: Input Remove$
If Val(Remove$) > 10 Or Val(Remove$) < 1 Then Run
DeleteTune
End If
WIPE "24"
Yellow: Centre "What will you call your new tune ", 24
White: Locate 24, 53: Input TuneName$
If TuneName$ = "" Then
Centre "No file changes made", 12: Sleep 1
Run
End If
WIPE "1224"
NT = NT + 1
Open "TuneDir" For Append As #1
Open "tunes" For Append As #2
Write #1, TuneName$
Write #2, Tune$
Close ' place name and tune number in tune directory
txt$ = "Added " + TuneName$ + " to file"
Centre txt$, 12: Sleep 1: Cls
NT = 0
Yellow: Centre "Existing Tunes", 12: White
Open "TuneDir" For Input As #1 ' get Tunes list
While Not EOF(1)
Input #1, OldTune$
NT = NT + 1
Print Tab(35); NT; Tab(40); OldTune$
Wend
Close: Sleep 2: Tune$ = ""
Run
Case 310 To 393 ' erase last char of tune
Tune$ = Left$(Tune$, Len(Tune$) - 1)
DisplayTune
End Select
KeyBoard:
Case 504 To 561 ' black keys
LastOp$ = ""
Select Case MX
Case 333 To 373
Tune$ = Tune$ + "C+"
Case 397 To 437
Tune$ = Tune$ + "E-"
Case 527 To 566
Tune$ = Tune$ + "F+"
Case 592 To 631
Tune$ = Tune$ + "A-"
Case 657 To 696
Tune$ = Tune$ + "B-"
End Select
Case 504 To 634 ' white keys
LastOp$ = ""
Select Case MX
Case 291 To 354
Tune$ = Tune$ + "C"
Case 356 To 419
Tune$ = Tune$ + "D"
Case 421 To 484
Tune$ = Tune$ + "E"
Case 486 To 549
Tune$ = Tune$ + "F"
Case 551 To 614
Tune$ = Tune$ + "G"
Case 616 To 679
Tune$ = Tune$ + "A"
Case 681 To 744
Tune$ = Tune$ + "B"
End Select
End Select
End Sub
Sub DisplayTune:
WipeTuneDisplay ' tune may be shorter, so erase previous tune display
Locate 14, 10
l = Len(Tune$)
For a = 1 To l
If a Mod (60) = 0 Then Print Tab(10); ' display tune in rows of 60 chars
Print Mid$(Tune$, a, 1);
Next
End Sub
Sub DeleteTune
Open "TuneDir" For Input As #1 ' get old files
Open "Tunes" For Input As #2
Open "TempTuneDir" For Output As #3 ' create new files
Open "TempTunes" For Output As #4
For a = 1 To Val(Remove$) - 1
Input #1, TuneName$: Write #3, TuneName$ ' copy records before selected into new file
Input #2, Tune$: Write #4, Tune$
Next
Input #1, TuneName$: Input #2, Tune$ ' read selected record and discard it
For a = Val(Remove$) + 1 To NT
Input #1, TuneName$: Write #3, TuneName$ ' copy remaining old records into new file
Input #2, Tune$: Write #4, Tune$
Next
Close
Kill "TuneDir": Kill "Tunes" ' delete old files
Name "TempTuneDir" As "TuneDir" ' rename new files as old files
Name "TempTunes" As "Tunes"
Sleep 2
End Sub
Sub Centre (txt$, linenum)
ctr = Int(CPR / 2 - Len(txt$) / 2) + 1 ' CPR is chars per row for this screen setting
Locate linenum, ctr ' place text at horiz centre of screen
Print txt$
End Sub
Sub WIPE (ln$) ' clear selected screen rows
If Len(ln$) = 1 Then ln$ = "0" + ln$
For a = 1 To Len(ln$) - 1 Step 2
wl = Val(Mid$(ln$, a, 2))
Locate wl, 1: Print Space$(CPR);
Next
End Sub
Sub WipeTuneDisplay
Locate 10, 1: Print Space$(880)
End Sub
Sub White
Color _RGB(255, 255, 255)
End Sub
Sub Yellow
Color _RGB(255, 255, 0)
End Sub
Sub Red
Color _RGB(255, 0, 0)
End Sub
Sub Instructions:
Yellow: Centre "Piano", 8: White: Print
Print " A simple mouse-driven programme to allow tunes to be composed, saved, and"
Print " re-played. They can be edited and saved later under the same name or a": Print
Print " new one. The tunes can use up to 7 octaves, with standard 13 semitones per"
Print " octave (13 TET) notation. It accommodates volume from 0% (silent) to 100% "
Print " of the system sound, and tempo from 32 bpm to 255 bpm, with note-lengths of"
Print " from 1 to 64, expressed as full-note fractions, e.g. 4 is 1 crotchet."
Yellow: Centre "Press Left-Mouse to begin", 19
Do
m = _MouseInput
b = _MouseButton(1)
Loop While b <> -1: Cls ' wait for left-mouse click
Sleep 1
End Sub
Of all the places on Earth, and all the planets in the Universe, I'd rather live here (Perth, Western Australia.) 
Please visit my Website at: http://oldendayskids.blogspot.com/
Please visit my Website at: http://oldendayskids.blogspot.com/
