view/trunk/Unit1.pas

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, mmsystem, StdCtrls, ComCtrls, Menus, DateUtils;

type
  TMidiKey = record
    tdata: TDateTime;
    key: integer;
    vol: integer;
  end;

  TForm1 = class(TForm)
    Label1: TLabel;
    Label2: TLabel;
    TrackBar1: TTrackBar;
    Button1: TButton;
    Label3: TLabel;
    Label4: TLabel;
    Label5: TLabel;
    Label6: TLabel;
    Label8: TLabel;
    Label7: TLabel;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure FormKeyDown(Sender: TObject; var Key: Word;
      Shift: TShiftState);
    procedure FormKeyUp(Sender: TObject; var Key: Word;
      Shift: TShiftState);
    procedure TrackBar1Change(Sender: TObject);
    procedure Button1Click(Sender: TObject);
  private
    { Private éž }
    MidiOut: hMidiOut;
    piano: DWord;
    down: array [0..12] of Boolean;
    Keys: array [0..12] of Word;
    vol: DWord;
    sharp: boolean;
    List: TList;
    tdata: TDateTime;
    procedure ClearRecord;
    procedure PlayRecorded;
    function ReadInt(var Int: integer; const Key: Word): Boolean;
    function KeySetting(const KeyArray: array of Char): Boolean;
    function MidiOutMessage(iStatus, iChannel, iData1, iData2: integer): Cardinal;
  public
    { Public éž }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.FormCreate(Sender: TObject);
var
  Res: DWORD;
  msg: string;
begin
        Res:=midiOutOpen(@MidiOut,MIDI_MAPPER,handle,0,CALLBACK_WINDOW);
  if Res <> 0 then
  begin
    case Res of
    MMSYSERR_BADDEVICEID:
        msg:='ÍÍOĚ';
    MMSYSERR_ALLOCATED:
        msg:='ůÉčÄ';
    MMSYSERR_NOMEM:
        msg:='ĚčÄ';
    MIDIERR_NOMAP:
        msg:='lhch}bvŞ';
    MIDIERR_NODEVICE:
        msg:='|[gŞ';
    else
        msg:='MIDI Open error.';
    end;
        MessageBox(Handle,PChar(msg),'Error',MB_OK);
  end;
        piano:=$90;
        vol:=$7F;
        sharp:=false;
        List:=TList.Create;
        KeySetting(['D','R','M','F','S','L','I','W']);
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
        midiOutClose(MidiOut);
        ClearRecord;
        List.Free;
end;

function TForm1.MidiOutMessage(iStatus, iChannel, iData1, iData2: integer): Cardinal;
const
  s: integer = $3C;
begin
        result:=(iStatus shl 24)or(iChannel shl 16)or((iData1+s) shl 8)or iData2;
end;

procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
var
  i: integer;
  s: ^TMidiKey;
  t: Boolean;
begin
        t:=false;
  case Key of
  VK_SPACE:
    if sharp = false then
    begin
        sharp:=true;
    end;
  VK_RETURN:
    if Label5.Caption = 'Record' then
    begin
        Label5.Caption:='';
    end else
        if Label5.Caption = '' then
    begin
        tdata:=Now;
        ClearRecord;
        Label5.Caption:='Record';
    end;
  VK_NUMPAD0:
  begin
        Label5.Caption:='Play';
        PlayRecorded;
  end;
  else
        t:=ReadInt(i,Key);
  end;
  if Label5.Caption = 'Play' then
  begin
        Label5.Caption:='';
  end;
  if t = false then
  begin
        Exit;
  end;
  if down[i] = false then
  begin
        down[i]:=true;
    if sharp = true then
    begin
      if i in [5,7,9,11] then
      begin
                inc(i);
      end else
                if i in [2,4] then
      begin
                dec(i);
      end else
      begin
                Exit;
      end;
    end;
    if Shift = [ssShift] then
    begin
        inc(i,12);
    end else
        if Shift = [ssCtrl] then
    begin
        dec(i,12);
    end;
    if Label5.Caption = 'Record' then
    begin
        New(s);
        s^.tdata:=Now-tdata;
        s^.key:=i;
        s^.vol:=vol;
        List.Add(s);
    end;
        i:=MiDiOutMessage($00,vol,i,piano);
        midiOutShortMsg(MidiOut,i);
  end;
end;

procedure TForm1.FormKeyUp(Sender: TObject; var Key: Word;
  Shift: TShiftState);
var
  i: integer;
  s: ^TMidiKey;
begin
  case Key of
  VK_SPACE:
  begin
    if sharp = true then
    begin
        sharp:=false;
    end;
        Exit;
  end;
  else
    if ReadInt(i,Key) = false then
    begin
        Exit;
    end;
  end;
  if down[i] = true then
  begin
        down[i]:=false;
    if Shift = [ssShift] then
    begin
        inc(i,12);
    end else
        if Shift = [ssCtrl] then
    begin
        dec(i,12);
    end;
    if Label5.Caption = 'Record' then
    begin
        New(s);
        s^.tdata:=Now-tdata;
        s^.key:=i;
        s^.vol:=0;
        List.Add(s);
    end;
        i:=MidiOutMessage($00,$00,i,piano);
        midiOutShortMsg(MidiOut,i);
  end;
end;

procedure TForm1.TrackBar1Change(Sender: TObject);
begin
        vol:=TrackBar1.Position;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
        Close;
end;

procedure TForm1.ClearRecord;
var
  i: integer;
begin
  for i:=0 to List.Count-1 do
  begin
        Dispose(List[i]);
  end;
        List.Clear;
end;

procedure TForm1.PlayRecorded;
var
  i, j, k, m, n: Word;
  c: cardinal;
  s: TMidiKey;
  t: TDateTime;
  u: string;
begin
        j:=0;
  if List.Count > 0 then
  begin
        Label7.Caption:='';
        t:=TMidiKey(List[0]^).tdata;
    for i:=0 to List.Count-1 do
    begin
        s:=TMidiKey(List[i]^);
        DecodeTime(s.tdata-t,j,k,m,n);
        Application.ProcessMessages;
      if Label5.Caption <> 'Play' then
      begin
                break;
      end;
        Sleep(1000*m+n);
        t:=s.tdata;
        c:=MidiOutMessage($00,s.vol,s.key,piano);
        midiOutShortMsg(MidiOut,c);
      if s.vol > 0 then
      begin
                k:=2;
        if s.key > 12 then
        begin
                s.key:=s.key-12;
                k:=3;
        end else
                if s.key < 0 then
        begin
                s.key:=s.key+12;
                k:=1;
        end;
        case s.key of
        0:
                u:='ÄŢ';
        1:
                u:='Ú/';
        2:
                u:='Ú';
        3:
                u:='Đ/';
        4:
                u:='Đ';
        5:
                u:='Ě§';
        6:
                u:='Ě§*';
        7:
                u:='ż';
        8:
                u:='ż*';
        9:
                u:='×';
        10:
                u:='×*';
        11:
                u:='ź';
        12:
                u:='ÄŢ^';
        else
                u:='';
        end;
        case k of
        1:
                u:='^'+u;
        3:
                u:=u+'^';
        end;
        if Label7.Caption = '' then
        begin
                Label7.Caption:=u;
        end else
        begin
                Label7.Caption:=Label7.Caption+','+u;
        end;
      end;
    end;
  end;
        Label5.Caption:='';
end;

function TForm1.ReadInt(var Int: integer; const Key: Word): Boolean;
var
  i, j: integer;
begin
        i:=Ord(Key);
        result:=false;
  for j:=0 to 7 do
  begin
    if i = Keys[j] then
    begin
      case j of
      0:
                Int:=0;
      1:
                Int:=2;
      2:
                Int:=4;
      3:
                Int:=5;
      4:
                Int:=7;
      5:
                Int:=9;
      6:
                Int:=11;
      7:
                Int:=12;
      end;
        result:=true;
        break;
    end;
  end;
end;

function TForm1.KeySetting(const KeyArray: array of Char): Boolean;
var
  i: integer;
begin
  if High(KeyArray) = 7 then
  begin
    for i:=0 to 7 do
    begin
        Keys[i]:=Ord(KeyArray[i]);
    end;
        result:=true;
  end else
  begin
        result:=false;
  end;
end;

end.