FreeBasic

В данном примере идет проигрывание миди нот двух октав, вы легко сможете на основе этого исходника соорудить миди пианино.
Платформа: Windows.
Автор: Antoni 2008.

#INCLUDE "windows.bi"

#INCLUDE Once "WIN\MMSYSTEM.BI"

' all bytes in  message bit 7 unset except first one (status byte)
'
'midi messages  length  1 (status)      2         3
' note off         3   &h80+channel    pitch      vel
' note on          3   &h90+channel    pitch      vel
' program change   2   &hC0+channel    preset nr

'channel=voice 0 to 15
' pitch= key 0 to 127  middle C=60
'velocity    1    127  standard  keyboard=64


#DEFINE mid_noteoff &h80

#DEFINE mid_noteon &h90

#DEFINE mid_prchange &hC0

'C  D  E  F  G  A  B  C
Dim Shared majscale(7) As Integer={60,62,64,65,67,69,71,72}
'C  D  Eb F  G  A  Bb C
Dim Shared minscale(7) As Integer={60,62,63,65,67,69,70,72}

Union midimsg
dw As Uinteger

b(3) As Ubyte

End Union



Type midisystem
    hmidiout As  hmidiout
    As Integer herror,patch
    mm As midimsg
    Declare Constructor()
    Declare Destructor()
    Declare Sub playnote (note As Integer, duration As Integer)
    Declare Sub setpatch(patch As Integer)
End Type

Constructor midisystem()
Dim As Integer n=midiOutGetNumDevs
If n=0 Then herror=-1
herror= midiOutOpen(@hMidiOut , -1, 0, 0, 0)
If hmidiout=0 Then herror=-2

setpatch 25

End Constructor


Destructor midisystem()
midiOutClose(hMidiOut)
midiOutReset(hMidiOut)
End Destructor


Sub midisystem.Playnote (note As Integer,duration As Integer)
    Dim As Integer x
    mm.b(0)=mid_noteon
    mm.b(1)=note
    mm.b(2)=64
    X = midiOutShortMsg(hMidiOut,mm.dw )
    Print x
    Dim t As Single=Timer+duration/1000

Do:Loop Until Timer>t
mm.b(0)=mid_noteoff
x= midiOutShortMsg(hMidiOut,mm.dw)
End Sub


Sub midisystem.setpatch(patch As Integer)

    mm.b(0)=mid_prchange
    mm.b(1)=patch
    midiOutShortMsg(hMidiOut,mm.dw )
End Sub


Sub playscale(m As midisystem Ptr,p As Integer Ptr, n As Integer)
    For i As Integer=0 To 7
        m->playnote(p[i],600)
        Sleep 100

    Next

End Sub


Dim As midisystem Ptr m =New midisystem
Print m->herror
If m->herror=0 Then

    Dim As Integer Ptr p

    ?"Playing a major scale"
    playscale(m,@majscale(0),8)
    Sleep 1000

    ?"Playing a minor scale"
    playscale(m,@minscale(0),8)


End If

Delete m
Print "ended"
Sleep