fmain.pas

Delphi钢琴源码

//
//      -'`"_         -'`" \
//     /     \       /      "
//    /     /\\__   /  ___   \    ADDRESS:
//   |      | \  -"`.-(   \   |     XI'AN Science and Technology University
//   |      |  |     | \"  |  |   ZIP CODE:
//   |     /  /  "-"  \  \    |     7100**
//    \___/  /  (o o)  \  (__/    NAME:
//         __| _     _ |__          ZHONG WAN
//        (      ( )      )       EMAIL:
//         \_\.-.___.-./_/          [e-mail]
//           __  | |  __          HOMEPAGE:
//          |  \.| |./  |           http://www.delphibox.com
//          | '#.   .#' |         OICQ:
//          |__/ '"" \__|           6036742
//        -/             \-       Write at Shanghai, China
//
//  Mid Piano Unit v1.0

unit fMain;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, Buttons, MMSystem, ExtCtrls, ShellAPI, CheckLst, ComCtrls,
  ActnList, IniFiles, PianoKeyboard, PianoChannels, MidiIn, MidiCommon,
  MidiFile, MidiOut, PianoTracks, MidiPlayer;

type
  TfrmMain = class(TForm)
    trbOctave: TTrackBar;
    cbOutput: TComboBox;
    MidiOutput1: TMidiOutput;
    btnOpen: TBitBtn;
    OpenDialog1: TOpenDialog;
    edtSpeed: TEdit;
    btnPlay: TBitBtn;
    btnStop: TBitBtn;
    lstEvent: TListBox;
    edtTime: TEdit;
    cbKeysGroupCount: TComboBox;
    Label1: TLabel;
    Label2: TLabel;
    Label3: TLabel;
    Label4: TLabel;
    Label5: TLabel;
    ActionList1: TActionList;
    actStop: TAction;
    actPlay: TAction;
    actOpen: TAction;
    MidiInput1: TMidiInput;
    PageControl1: TPageControl;
    tsTrack: TTabSheet;
    TabSheet1: TTabSheet;
    PageControl2: TPageControl;
    tsCommon: TTabSheet;
    tsChannel: TTabSheet;
    trbVolume: TTrackBar;
    Label6: TLabel;
    UpDown1: TUpDown;
    cbInput: TComboBox;
    Label7: TLabel;
    cbbColor: TComboBox;
    PianoTracks1: TPianoTracks;
    actReset: TAction;
    btnReset: TBitBtn;
    btnExit: TBitBtn;
    actExit: TAction;
    PianoChannels1: TPianoChannels;
    PianoKeyboard1: TPianoKeyboard;
    MidiPlayer1: TMidiPlayer;
    MidiFile1: TMidiFile;
    Label8: TLabel;
    actRecord: TAction;
    pbLength: TProgressBar;
    actInfo: TAction;
    BitBtn1: TBitBtn;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure cbKeysGroupCountChange(Sender: TObject);
    procedure actOpenExecute(Sender: TObject);
    procedure actPlayExecute(Sender: TObject);
    procedure actStopExecute(Sender: TObject);
    procedure trbOctaveChange(Sender: TObject);
    procedure cbOutputChange(Sender: TObject);
    procedure cbbColorChange(Sender: TObject);
    procedure trbVolumeChange(Sender: TObject);
    procedure UpDown1Changing(Sender: TObject; var AllowChange: Boolean);
    procedure MidiInput1MidiInput(Sender: TObject);
    procedure PianoKeyboard1Keyboard(Event, data1, data2: Byte);
    procedure FormShortCut(var Msg: TWMKey; var Handled: Boolean);
    procedure FormKeyDown(Sender: TObject; var Key: Word;
      Shift: TShiftState);
    procedure FormKeyUp(Sender: TObject; var Key: Word;
      Shift: TShiftState);
    procedure PianoChannels1ChannelClick(Sender: TObject);
    procedure PianoTracks1TrackClick(Sender: TObject);
    procedure actResetExecute(Sender: TObject);
    procedure actExitExecute(Sender: TObject);
    procedure MidiPlayer1MidiEvent(Event: PMidiEvent);
    procedure MidiPlayer1ReadyEvent(Track: Integer);
    procedure MidiPlayer1SpeedChange(Value: Integer);
    procedure MidiPlayer1UpdateEvent(Sender: TObject);
    procedure actRecordExecute(Sender: TObject);
    procedure pbLengthMouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure actInfoExecute(Sender: TObject);
  private
    //BtnCurrent: TPianoButton;
    procedure SaveIniFile;
    procedure LoadIniFile;
    procedure InitMidiIO;
    procedure MidiClose;
    procedure MidiOpen;
    procedure OpenMidiFile(FileName: string);
    procedure WMDropFiles(var Msg: TWMDropFiles); message WM_DROPFILES;
    function GetTrackColor(pEvent: PMidiEvent): TPianoColor;
    { Private declarations }
  protected
    procedure SentAllNotesOff;
  public
    { Public declarations }
  end;

const
  CMaxVolume = 65535;
  CStepVolume = 10000;

var
  MidiOpened: Boolean = False;

resourcestring
  rsErrorOpenMidi = 'Open MIDI Device failed, Please check configuration!';
  rsRebuildKeyboard = 'This operation will cost few time, continue?';
  rsBtnOpen = 'Open';
  rsBtnPlay = 'Play';
  rsBtnStop = 'Stop';
  rsBtnPause = 'Pause';
  rsBtnResume = 'Resume';

var
  frmMain: TfrmMain;

implementation

uses fInfo;

{$R *.dfm}

procedure TfrmMain.InitMidiIO;
var
  iDevice: Integer;
begin
  cbInput.Clear;
  for iDevice := 0 to MidiInput1.NumDevs - 1 do
  begin
    MidiInput1.DeviceID := iDevice;
    cbInput.Items.Add(MidiInput1.ProductName);
  end;
  cbInput.ItemIndex := 0;
  for iDevice := 0 to MidiOutput1.NumDevs - 1 do
  begin
    MidiOutput1.DeviceID := iDevice;
    cbOutput.Items.Add(MidiOutput1.ProductName);
  end;
  cbOutput.ItemIndex := 0;
end;

procedure TfrmMain.SaveIniFile;
begin
  with TInifile.Create(ChangeFileExt(ParamStr(0), '.ini')) do
  begin
    WriteString('PianoEx', 'LastFile', MidiFile1.Filename);
    WriteInteger('PianoEx', 'InputIndex', cbInput.ItemIndex);
    WriteInteger('PianoEx', 'OutPutIndex', cbOutput.ItemIndex);
    WriteInteger('PianoEx', 'OctaveIndex', trbOctave.Position);
    WriteInteger('PianoEx', 'CountIndex', cbKeysGroupCount.ItemIndex);
    WriteInteger('PianoEx', 'ColorIndex', cbbColor.ItemIndex);
    
    Free;
  end;
end;

procedure TfrmMain.LoadIniFile;
var
  MidiFileName: String;
begin
  with TInifile.Create(ChangeFileExt(ParamStr(0), '.ini')) do
  begin
    cbInput.ItemIndex := ReadInteger('PianoEx', 'InputIndex', 0);
    if cbInput.ItemIndex <> 0 then
      cbOutputChange(cbInput);
    cbOutput.ItemIndex := ReadInteger('PianoEx', 'OutPutIndex', 0);
    if cbOutput.ItemIndex <> 0 then
      cbOutputChange(cbOutput);

    trbOctave.Position := ReadInteger('PianoEx', 'OctaveIndex', 3);
    if trbOctave.Position <> 3 then
      PianoKeyboard1.PianoOctave := trbOctave.Position;
    cbKeysGroupCount.ItemIndex := ReadInteger('PianoEx', 'CountIndex', 0);
    if cbKeysGroupCount.ItemIndex <> 0 then
      PianoKeyboard1.PianoGroup := StrToInt(cbKeysGroupCount.Text);
    cbbColor.ItemIndex := ReadInteger('PianoEx', 'ColorIndex', 0);
    if cbbColor.ItemIndex <> 0 then
      PianoKeyboard1.PianoColor := TPianoColor(cbbColor.ItemIndex);

    MidiFileName := ReadString('PianoEx', 'LastFile', '');
    if (MidiFileName <> '') and (FileExists(MidiFileName)) then
      OpenMidiFile(MidiFileName);

    Free;
  end;
end;

procedure TfrmMain.MidiOpen;
begin
  if cbInput.Text <> '' then
  begin
    MidiInput1.ProductName := cbInput.Text;
    MidiInput1.Open;
    MidiInput1.Start;
  end;
  if cbOutput.Text <> '' then
  begin
    MidiOutput1.ProductName := cbOutput.Text;
    MidiOpened := MidiOutput1.Open;
    if not MidiOpened then
      ShowMessage(rsErrorOpenMidi);
  end;
end;

procedure TfrmMain.MidiClose;
begin
  if MidiOpened then
  begin
    MidiOutput1.Close;
    MidiOpened := False;
  end;
  MidiInput1.Close;
end;

procedure TfrmMain.FormCreate(Sender: TObject);
begin
  DragAcceptFiles(Handle, True); // Enable dragfile
  // Find Midi Input/Output
  InitMidiIO;
  // Open Midi Device
  MidiOpen;
  // Set Midi Volume
  trbVolume.Max := CMaxVolume div CStepVolume;
  trbVolume.Position := trbVolume.Max - MidiOutput1.MidiVolume div CStepVolume;
  // IniFile
  LoadIniFile;
end;

procedure TfrmMain.FormDestroy(Sender: TObject);
begin
  MidiClose;
  // IniFile
  SaveIniFile;
end;

procedure TfrmMain.SentAllNotesOff;
var
  mEvent: TMyMidiEvent;
  iChannel: Integer;
begin
  mEvent := TMyMidiEvent.Create;
  for iChannel := 0 to 15 do
  begin
    mEvent.MidiMessage := $B0 + iChannel;
    mEvent.data1 := $7E;
    mEvent.data2 := 0;
    if MidiOpened then
      MidiOutput1.PutMidiEvent(mEvent);
    PianoKeyboard1.DoMidiEvent(mEvent.MidiMessage, mEvent.data1, mEvent.data2, TPianoColor(cbbColor.ItemIndex));
  end;
  mEvent.Destroy;
  // Reset controls
end;

function TfrmMain.GetTrackColor(pEvent: PMidiEvent): TPianoColor;
var
  iTrack: Byte;
begin
  Result := TPianoColor(-1);
  if pEvent^.iEvent = $FF then Exit;
  iTrack := pEvent.iTrack - 1;
  case PianoTracks1.GetTrackHand(iTrack) of
    thUnknow: Result := TPianoColor(cbbColor.ItemIndex);
    thLeft: Result := pcBlue;
    thRight: Result := pcRed;
  end;
end;

procedure TfrmMain.MidiPlayer1MidiEvent(Event: PMidiEvent);
var
  mEvent: TMyMidiEvent;
begin
  if not (Event^.iEvent = $FF) then
  begin
    mEvent := TMyMidiEvent.Create;
    mEvent.MidiMessage := Event^.iEvent;
    mEvent.data1 := Event^.iData1;
    mEvent.data2 := Event^.iData2;
    MidiOutput1.PutMidiEvent(mEvent);
    PianoChannels1.DoChannelBar(mEvent.MidiMessage and $F, mEvent.Data1);
    mEvent.Destroy;