(* ====================================================== *)
(* project1.dpr *)
(* MIDI ohne den Mediaplayer *)
(* Copyright (C) 2000 Wolfgang Beintvogl & Toolbox *)
(* Compiler: Delphi32 *)
(* ====================================================== *)
{$MINSTACKSIZE $00004000}
{$MAXSTACKSIZE $00100000}
{$IMAGEBASE $00400000}
{$APPTYPE GUI}
PROGRAM Project1;
USES
Forms,
Unit1
in '
Unit1.pas'
{Form1};
{$R *.RES}
BEGIN
Application.Initialize;
Application.CreateForm(TForm1, Form1);
Application.Run;
END.
//------------------------project1.dpr ------- E N D E--------------------------
(* ====================================================== *)
(* MIDI ohne den Mediaplayer *)
(* Copyright (C) 2000-2002 Wolfgang Beintvogl & Toolbox *)
(* Compiler: Delphi32 *)
(* ====================================================== *)
UNIT Unit1;
INTERFACE
USES
Windows, Messages, SysUtils, Classes, Graphics, Controls,
Forms, Dialogs, StdCtrls, MMSystem, ExtCtrls;
TYPE
TForm1 =
CLASS(TForm)
Button2 : TButton;
Label1 : TLabel;
Timer1 : TTimer;
CheckBox1 : TCheckBox;
Label2 : TLabel;
CheckBox2 : TCheckBox;
PROCEDURE Button2Click(Sender: TObject);
PROCEDURE FormClose(Sender: TObject;
VAR Action: TCloseAction);
PROCEDURE FormCreate(Sender: TObject);
PROCEDURE Timer1Timer(Sender: TObject);
PROCEDURE CheckBox1Click(Sender: TObject);
PROCEDURE CheckBox2Click(Sender: TObject);
PRIVATE
ERROR : MCIERROR;
errString :
ARRAY[0..255]
OF CHAR;
MCIID : MCIDEVICEID;
dwParam : DWord;
openParms : TMCI_OPEN_PARMS;
Sound, Zufall : BOOLEAN;
MYTFN1 :
STRING;
PROCEDURE StatusMidi;
PROCEDURE PlayMidi;
PROCEDURE StopMidi;
PROCEDURE Res2Temp;
END;
VAR
Form1: TForm1;
IMPLEMENTATION
{$R *.DFM}
{$R Midi.Res}
PROCEDURE TForm1.StatusMidi;
VAR
StatusParm: TMCI_Status_Parms;
FFlags : LongInt;
BEGIN
FFlags := mci_Wait
OR mci_Status_Item;
StatusParm.dwItem := mci_Status_Mode;
Error := mciSendCommand(MCIID, mci_Status, FFlags,
LongInt(@StatusParm));
(* 2 = Playing / 1 = Stopped *)
IF ((StatusParm.dwReturn - 524) <> 2)
AND Sound
THEN
PlayMidi;
IF ((StatusParm.dwReturn - 524) = 1)
OR (
NOT Sound)
THEN
StopMidi;
Label1.Caption := IntToStr(StatusParm.dwReturn - 524);
END;
PROCEDURE TForm1.PlayMidi;
VAR
S :
STRING;
BEGIN
S := MYTFN1;
openParms.lpstrElementName := PChar(S);
openParms.lpstrDeviceType := '
sequencer';
dwParam := DWord(@openParms);
ERROR := mciSendCommand(0, MCI_OPEN,MCI_OPEN_TYPE
OR
MCI_OPEN_ELEMENT, dwParam);
IF ERROR <> 0
THEN BEGIN
mciGetErrorString(ERROR, errString, 255);
Label1.Caption := '
MCI_OPEN: ' + errString;
END ELSE BEGIN
Label1.Caption := '
MCI_OPEN ausgeführt';
END;
mciId := openParms.wDeviceID;
ERROR := mciSendCommand(mciId, MCI_PLAY,
MCI_NOTIFY, dwParam);
IF ERROR <> 0
THEN BEGIN
mciGetErrorString(ERROR, errString, 255);
Label1.Caption := '
MCI_PLAY: ' + errString;
END ELSE BEGIN
Label1.Caption := '
MCI_PLAY ausgeführt';
END;
END;
PROCEDURE TForm1.StopMidi;
BEGIN
ERROR := mciSendCommand(mciId, MCI_CLOSE, 0, 0);
IF ERROR <> 0
THEN BEGIN
mciGetErrorString(ERROR, errString, 255);
Label1.Caption := '
MCI_CLOSE: ' + errString;
END ELSE BEGIN
Label1.Caption := '
MCI_CLOSE ausgeführt';
END;
IF Zufall
THEN Res2Temp;
END;
PROCEDURE TForm1.Button2Click(Sender: TObject);
BEGIN
Close;
END;
PROCEDURE TForm1.FormClose(Sender: TObject;
VAR Action: TCloseAction);
BEGIN
IF FileExists(MYTFN1)
THEN DeleteFile(MYTFN1);
END;
{$WARNINGS OFF}
PROCEDURE TForm1.Res2Temp;
VAR
RS: TCustomMemoryStream;
S :
STRING;
BEGIN
S := '
MIDI_' + Inttostr(random(4) + 1);
TRY
RS := TResourceStream.Create(hInstance, S, '
MIDI');
RS.SavetoFile(MYTFN1);
FINALLY
RS.Free;
END;
END;
{$WARNINGS ON}
PROCEDURE TForm1.FormCreate(Sender: TObject);
VAR
Path :
ARRAY[0..MAX_PATH]
OF CHAR;
//S, F : TStream;
N : INTEGER;
BEGIN
GetTempPath(Max_Path, Path);
N := 0;
WHILE FileExists(Path + '
~BS' + IntToStr(N) + '
.MID')
DO
Inc(N);
MYTFN1 := Path + '
~BS' + IntToStr(N) + '
.MID';
// S := TResourceStream.Create(HInstance, 'MIDI_1', 'MIDI');
// F := TFileStream.Create(MYTFN1, FMCreate);
// F.CopyFrom(S, S.Size);
// S.Free;
// F.Free;
Res2Temp;
Sound := TRUE;
Zufall := TRUE;
END;
PROCEDURE TForm1.Timer1Timer(Sender: TObject);
BEGIN
StatusMidi;
END;
PROCEDURE TForm1.CheckBox1Click(Sender: TObject);
BEGIN
Sound := CheckBox1.Checked;
END;
PROCEDURE TForm1.CheckBox2Click(Sender: TObject);
BEGIN
Zufall := CheckBox2.Checked;
END;
END.