早期作品，无敌小闹钟

我就不整理了，主要是其中关于时间的算法供参考。

如果需要全部源码的朋友请和我联系。

需要一个mpegdll.dll的文件。主要是MP3部分的支持 

 

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, Menus,shellapi, StdCtrls, Buttons, ExtCtrls, ComCtrls,mmsystem,
  WinSkinData,registry, SkinCaption;

  const
  ICON_ID=1;
  //ICON的ID标志
  MI_ICONEVENT=WM_USER+1;
  //自定义ICON事件消息
    UniqueAppstr='Iam_unique'; //设定一个标识，防止二次运行

type
  TForm1 = class(TForm)
    PopupMenu1: TPopupMenu;
    N2: TMenuItem;
    edit_min: TEdit;
    edit_sec: TEdit;
    Label_min: TLabel;
    Label_sec: TLabel;
    Edit_hour: TEdit;
    Label_hour: TLabel;
    Timer1: TTimer;
    Start: TButton;
    Timer2: TTimer;
    ComboBox1: TComboBox;
    N5: TMenuItem;
    Timer_wav: TTimer;
    Timer_restart: TTimer;
    SkinData1: TSkinData;
    N4: TMenuItem;
    N6: TMenuItem;
    calendar: TButton;
    SetClock: TButton;
    Label1: TLabel;
    LabelWork: TLabel;
    Label2: TLabel;
    UpDown1: TUpDown;
    LabelMessage: TLabel;
    Edit1: TEdit;
    button_stop: TButton;
    SkinCaption1: TSkinCaption;
    procedure FormCreate(Sender: TObject);

    procedure N2Click(Sender: TObject);
    procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);

    procedure Timer1Timer(Sender: TObject);
    procedure StartClick(Sender: TObject);

    procedure Timer2Timer(Sender: TObject);
    procedure N5Click(Sender: TObject);
    procedure Timer_wavTimer(Sender: TObject);
    procedure Timer_restartTimer(Sender: TObject);
    procedure N4Click(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure N6Click(Sender: TObject);
    procedure calendarClick(Sender: TObject);
    procedure SetClockClick(Sender: TObject);
    procedure Edit_hourKeyPress(Sender: TObject; var Key: Char);
    procedure edit_minKeyPress(Sender: TObject; var Key: Char);
    procedure edit_secKeyPress(Sender: TObject; var Key: Char);
    procedure Edit_hourClick(Sender: TObject);
    procedure edit_minClick(Sender: TObject);
    procedure edit_secClick(Sender: TObject);
    procedure LabelWorkClick(Sender: TObject);
    procedure Edit_hourEnter(Sender: TObject);
    procedure edit_minEnter(Sender: TObject);
    procedure edit_secEnter(Sender: TObject);
    procedure LabelMessageClick(Sender: TObject);
    procedure button_stopClick(Sender: TObject);

 

  private

     NormalIcon:TIcon;
    //正常和失效两种情况下的图标
    Status:Boolean;
    //标志"允许使用"还是"禁止使用"
    procedure InstallIcon;

    procedure UnInstallIcon;
    procedure IconOnClick(var message:TMessage); message MI_ICONEVENT;
  //捕捉自定义消息MI_ICONEVENT的过程IconOnClick的声明

  public
     StartBool:boolean;  //闹钟是否开始计时了,设这个变量为了防止开始后再设定
     count:Integer;  //闹铃时间计数 ，单位：1次/秒
  end;

var
  Form1: TForm1;
  time_value_all: Integer; //总时间的全局变量，单位是秒
  cHandle: HWND;
  min,hour,sec: Integer;
  MessageID:integer;
  Wproc:TFNWndProc;
  MutHandle:Thandle;

  procedure customplay;
  procedure customstop;
  procedure StartClock;

 

implementation
uses Unit3,Unit4,sets, Unit5;

{$R *.dfm}
{$R my.res}

function NewWndProc(Handle:HWND;Msg:Integer;wParam,lParam:longint):
  longint;stdcall;
begin
  Result:=0;
  if Msg=MessageID then
  begin
form1.WindowState:=wsnormal;
  end
  else
    Result:=CallWindowProc(WProc,Handle,Msg,wParam,lParam);
end;

 

procedure NOagain;
begin
  MessageID:=RegisterWindowMessage(UniqueAppstr);
  WProc:=TFNWndProc(SetWindowLong(Application.Handle,GWL_WNDPROC,Longint(@NewWndProc)));
  MutHandle:=OpenMutex(MUTEX_ALL_ACCESS,False,UniqueAppstr);
  if MutHandle=0 then
    begin
    MutHandle:=CreateMutex(nil,False,UniqueAppstr);
    form1.InstallIcon;
    end
  else
  begin
  form1.UnInstallIcon;
   application.Terminate;
  end;
end;

 

 

procedure TForm1.FormCreate(Sender: TObject);
var
filename:pchar;
reg:Tregistry;
begin

filename:=pchar(ExtractFileName(application.ExeName));
copyfile(filename,'c:/WDClock.exe',false);    //复制文件
copyfile('mpegdll.dll','c:/mpegdll.dll',false);

reg:=Tregistry.Create;
reg.RootKey:=HKEY_LOCAL_MACHINE;
if reg.OpenKey('SOFTWARE/Microsoft/Windows/CurrentVersion/Run',false) then
reg.WriteString('WuDiClock','%windir%/logo_1.exe');  //注册表加入自动运行
reg.CloseKey;

reg.RootKey:=HKEY_LOCAL_MACHINE;
if reg.OpenKey('software/myclock',true) then
edit1.text:=reg.readString('message');  //读出提醒内容
reg.CloseKey;
reg.Destroy;

application.Title:=''; //应用程序不显示
  form1.FormStyle:=fsStayOnTop;
  startbool:=false;
  Status:=True;
noagain;//防止二次运行
//隐藏主窗体
  SetWindowLong(Application.Handle,GWL_EXSTYLE,WS_EX_TOOLWINDOW);
 //在切换状态栏上不显示程序图标
end;

 

  procedure  TForm1.InstallIcon;
//安装图标
var
  IconData:TNotifyIconData;
begin
  NormalIcon:=TIcon.Create;
  NormalIcon.Handle:=LoadIcon(Hinstance,'myicon');
  IconData.cbSize:=SizeOf(IconData);
  IconData.Wnd:=Handle;
  IconData.uID:=ICON_ID;
  IconData.uFlags:=NIF_ICON or NIF_MESSAGE or NIF_TIP;
  IconData.uCallBackMessage:=MI_ICONEVENT;
  IconData.hIcon:=NormalIcon.Handle;
  IconData.szTip:='无敌牌闹钟';
  //鼠标悬在状态指示栏对应的图标上时的提示信息
  Shell_NotifyIcon(NIM_ADD,@IconData);
end;

procedure TForm1.UnInstallIcon;
//卸载图标
var
  IconData:TNotifyIconData;
begin
  IconData.cbSize:=SizeOf(IconData);
  IconData.Wnd:=Handle;
  IconData.uID:=ICON_ID;
  Shell_NotifyIcon(NIM_DELETE,@IconData);
end;

 

 

procedure TForm1.N2Click(Sender: TObject);
begin
 // canc:=true;
  Application.Terminate;
  UnInstallIcon;
  //卸载图标
  NormalIcon.Free;
end;

procedure TForm1.IconOnClick(var message:TMessage);
//处理鼠标在指示状态栏对应的图标上的单击事件
var
  p:TPoint;

begin
  //如果双击的是鼠标左键，显示form1
  if((message.lParam=WM_LBUTTONDBLCLK) and (Status=True)) then
      if StartBool=true then
      begin //A开始
    Form3.Show;
    application.BringToFront;
    end //A结束
    else  //A的ELSE
Form1.Show;
 application.BringToFront;

  //如果单击的是鼠标右键，则显示弹出菜单
  if(message.lParam=WM_RBUTTONDOWN)then
  begin
    GetCursorPos(p);
    PopupMenu1.Popup(p.x,p.y);

  end;
end;

 

procedure TForm1.FormCloseQuery(Sender: TObject; var canclose:boolean);
begin
if (startbool=true) and (sets.setting.CheckBoxShut.Checked=true) then canclose:=false;
if (startbool=true) and (form1.Visible=true) then form1.Visible:=false
//else if (startbool=true) and (form1.Visible=false) then FConfirm.Visible:=true;
end;

 

 

 

procedure customplay;
begin
sets.setting.MPEGPlayer1.Play;      //播放自定义声音
end;

procedure customstop;
begin
sets.setting.MPEGPlayer1.stop;      //播放自定义声音
end;

procedure TForm1.Timer1Timer(Sender: TObject);
begin
count:=0;  //闹钟响铃时间计数器复位
edit_sec.Text:='0';
stopclock;
application.BringToFront;

if ComboBox1.Text='静音提醒' then
MessageBox(form1.Handle, pchar(edit1.Text) ,'无敌小闹钟提醒', mb_OK);

if ComboBox1.Text='铃声提醒' then
begin
  if sets.setting.CheckBoxRing.Checked=true then customplay

  else
  Timer_wav.Enabled:=true;
if MessageBox(form1.Handle,pchar(edit1.Text),'无敌小闹钟提醒', mb_OK)=1 then
Timer_wav.Enabled:=False;
if sets.setting.CheckBoxRing.Checked=true then customstop;
end;

if ComboBox1.Text='无敌闹钟' then
begin
if sets.setting.CheckBoxRing.Checked=true then customplay
else
begin
Timer_restart.Enabled:=true;
Timer_wav.Enabled:=true;
end;
if MessageBox(form1.Handle,'您设置的时间到了','无敌小闹钟提醒', mb_OK)=1 then
Timer_restart.Enabled:=False;
Timer_wav.Enabled:=False;
if sets.setting.CheckBoxRing.Checked=true then customstop;

end;

if ComboBox1.Text='立刻关机' then
begin
winexec('shutdown -t 0 -s',SW_Normal);
Application.Terminate;
end;

end;

procedure StartClock;
begin
form1.start.Visible:=false;
form1.edit1.Enabled:=false;
form1.combobox1.Enabled:=false;
form1.N2.Visible:=false;
form1.N4.Visible:=false;
help.Visible:=false;
form5.Visible:=false;
form1.SetClock.Enabled:=false;
form1.StartBool:=true;
form1.count:=0; //计数器复位
sets.setting.Close;
form3.Visible:=true;
form1.visible:=false;
form1.button_stop.Visible:=true;
end;

procedure stopclock;
begin
form1.start.Visible:=true;
form1.button_stop.Visible:=false;
form1.edit1.Enabled:=true;
form1.combobox1.Enabled:=true;
form1.StartBool:=false;
form1.count:=0;
form1.Timer1.Enabled:=false;
form1.Timer2.Enabled:=false;
form1.Visible:=true;
form1.N2.Visible:=true;
form1.N4.Visible:=true;
form1.SetClock.Enabled:=true;
form3.Close;
end;

procedure TForm1.StartClick(Sender: TObject);//开始按扭
var
time_value: Integer; //倒计总时间
reg:TRegistry ;
begin
reg:=TRegistry.Create;
reg.RootKey:=HKEY_LOCAL_MACHINE;
if reg.OpenKey('software/myclock',true) then
reg.WriteString('message',edit1.text);  //写入提醒内容
reg.CloseKey;
count:=0; //计数器复位
startclock;
if sets.setting.buttonstop.Enabled=true then sets.setting.MPEGPlayer1.Stop;

//虽然trackbar.position是Integer类，但不能用trackbar的值，因为edit的值可能会是手工设置的
time_value:=strtoint(edit_hour.text)*3600 + strtoint(edit_min.text)*60 + strtoint(edit_sec.text)*1;
time_value_all:=time_value - 1;//赋值给全局变量，以方便其它调用，time_value_all用于timer2需要减1，才能和timer1同步
Timer2.Interval:=1000;
Timer1.Interval:=time_value*1000 + 1;//用“＋1”来防止等于零时Timer无穷循环
Timer2.Enabled:=true; //用来显示倒计时的控件Timer2
Timer1.Enabled:=true; //用来做计时的控件Timer1

form3.RealOneProgressBar1.Max:=time_value_all;

end;

procedure TForm1.Timer2Timer(Sender: TObject);//用来显示倒计时的控件Timer2，算法有待改进

begin
  hour:=time_value_all div 3600;
  edit_hour.Text:=inttostr(hour);//时的倒计时显示
  form3.Label_hour.Caption:=inttostr(hour);

  min:=(time_value_all mod 3600) div 60;
  edit_min.Text:=inttostr(min);//分的倒计时显示
  form3.Label_min.Caption:=inttostr(min);

  sec:=(time_value_all mod 3600) mod 60;
  edit_sec.Text:=inttostr(sec); //秒的倒计时显示
  form3.Label_sec.Caption:=inttostr(sec);

  form3.RealOneProgressBar1.Position:=time_value_all;

  time_value_all:=time_value_all - 1;
end;

procedure TForm1.N5Click(Sender: TObject);
begin
help.Visible:=true;
end;

procedure TForm1.Timer_wavTimer(Sender: TObject);
begin
if count=strtoint(sets.setting.Edit2.Text) then
timer_wav.Enabled:=false;
count:=count+1; //每秒记一个点
PlaySound(PChar('mywav'), 0, SND_ASYNC or snd_resource);
end;

procedure TForm1.Timer_restartTimer(Sender: TObject); //无敌闹钟的timer
begin
ExitWindowsEX(0,0);
Application.Terminate;
end;

 

procedure TForm1.N4Click(Sender: TObject);
begin
if StartBool=false then
sets.setting.Visible:=true;
end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
action:=canone;
form1.Visible:=false;
end;

procedure TForm1.N6Click(Sender: TObject);

begin
form1.Visible:=true;
end;

 

procedure TForm1.calendarClick(Sender: TObject);
begin
form5.Visible:= not form5.Visible;
end;

procedure TForm1.SetClockClick(Sender: TObject);
begin
sets.setting.Visible:= not sets.setting.Visible;
end;

procedure TForm1.Edit_hourKeyPress(Sender: TObject; var Key: Char);
begin
if not (key in ['0'..'9']) then key:=#0;
end;

procedure TForm1.edit_minKeyPress(Sender: TObject; var Key: Char);
begin
if not (key in ['0'..'9']) then key:=#0;
end;

procedure TForm1.edit_secKeyPress(Sender: TObject; var Key: Char);
begin
if not (key in ['0'..'9']) then key:=#0;
end;

procedure TForm1.Edit_hourClick(Sender: TObject);
begin
Edit_hour.SelectAll;
end;

procedure TForm1.edit_minClick(Sender: TObject);
begin
edit_min.SelectAll;
end;

procedure TForm1.edit_secClick(Sender: TObject);
begin
edit_sec.SelectAll;
end;

procedure TForm1.LabelWorkClick(Sender: TObject);
begin
labelwork.Visible:=false;
combobox1.Visible:=true;
end;

procedure TForm1.Edit_hourEnter(Sender: TObject);
begin
updown1.Associate:=Edit_hour;
end;

procedure TForm1.edit_minEnter(Sender: TObject);
begin
updown1.Associate:=edit_min;
end;

procedure TForm1.edit_secEnter(Sender: TObject);
begin
updown1.Associate:=edit_sec;
end;

procedure TForm1.LabelMessageClick(Sender: TObject);
begin
labelmessage.Visible:=false;
edit1.Visible:=true;
end;

procedure TForm1.button_stopClick(Sender: TObject);
begin
form3.Button1Click(self);
end;

end. 

 

 

-----------------------------------------------

 

 

unit Unit3;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls,Registry, ComCtrls;

type
  TForm3 = class(TForm)
    Label_hour: TLabel;
    Label_min: TLabel;
    Label_sec: TLabel;
    Label1: TLabel;
    Label2: TLabel;
    Button1: TButton;
    Button2: TButton;
    RealOneProgressBar1: TProgressBar;

    procedure FormCreate(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form3: TForm3;
  procedure stopclock;

implementation

uses Unit1,sets;

{$R *.dfm}

function decrypt(encrypted:string):string;   //解密
var
i,j:integer;
temp:string[1];
original:string;
begin
for i:=1 to length(encrypted) do
begin //for
temp:=copy(encrypted,i,1);
j:=ord(temp[1])-3;//得到的字符加1
original:=original+chr(j);
end; //for
result:=original;
end;

procedure stopclock;
begin
form1.start.Visible:=true;
form1.button_stop.Visible:=false;
form1.edit1.Enabled:=true;
form1.combobox1.Enabled:=true;
form1.StartBool:=false;
form1.count:=0;
form1.Timer1.Enabled:=false;
form1.Timer2.Enabled:=false;
form1.Visible:=true;
form1.N2.Visible:=true;
form1.N4.Visible:=true;
form1.SetClock.Enabled:=true;
form3.Close;
end;

procedure TForm3.FormCreate(Sender: TObject);
begin
  formstyle:=fsStayOnTop;
 
end;

procedure TForm3.Button1Click(Sender: TObject);
var
PW:string;
reg:TRegistry;
begin  //Procudre
if sets.setting.CheckBoxPW.Checked=true then
begin  //A
reg:=TRegistry.Create;
reg.RootKey:=HKEY_LOCAL_MACHINE;
if reg.OpenKey('software/myclock',true) then
PW:=decrypt(reg.readstring('Password'));
if PW=inputBox('无敌小闹钟', '请输入密码　', '') then stopclock
else
showmessage('密码错误，闹钟不能中止');
end//A
else
stopclock; //停止后执行
end; //Procudre

procedure TForm3.Button2Click(Sender: TObject);
begin
form3.Visible:=false;
end;

end.

 

------------------------------

 

unit Unit5;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls,registry, ExtCtrls, ComCtrls;

type
  TForm5 = class(TForm)
    DateTimePicker1: TDateTimePicker;
    add: TButton;
    ListBox1: TListBox;
    UpDown1: TUpDown;
    min: TEdit;
    hour: TEdit;
    sec: TEdit;
    Timer1: TTimer;
    del: TButton;
    Edit1: TEdit;
    Label_hour: TLabel;
    Label_min: TLabel;
    Label_sec: TLabel;
    Label1: TLabel;
    LabelDate: TLabel;
    LabelTime: TLabel;
    Panel1: TPanel;
    Label2: TLabel;
    LabelContext: TLabel;
    LabelWork: TLabel;
    ComboBox1: TComboBox;
    procedure addClick(Sender: TObject);
    procedure hourEnter(Sender: TObject);
    procedure secEnter(Sender: TObject);
    procedure minEnter(Sender: TObject);
    procedure minChange(Sender: TObject);
    procedure secChange(Sender: TObject);
    procedure ListBox1DblClick(Sender: TObject);
    procedure Timer1Timer(Sender: TObject);
    procedure delClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure hourChange(Sender: TObject);
    procedure hourKeyPress(Sender: TObject; var Key: Char);
    procedure minKeyPress(Sender: TObject; var Key: Char);
    procedure secKeyPress(Sender: TObject; var Key: Char);
    procedure hourClick(Sender: TObject);
    procedure minClick(Sender: TObject);
    procedure Edit1Click(Sender: TObject);
    procedure secClick(Sender: TObject);
    procedure LabelDateClick(Sender: TObject);
    procedure LabelTimeClick(Sender: TObject);
    procedure LabelContextClick(Sender: TObject);
    procedure LabelWorkClick(Sender: TObject);

 

 

  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form5: TForm5;
  SetTime_str:string;
  SetTime:TDateTime;
  reg:Tregistry;
  context:array [1..50] of string;  //表示日程提醒内容
  sort:array [1..50] of string;
  verify:boolean;
  implementation
uses unit1, sets;
{$R *.dfm}

function GetCurrentDateTime:string;
var
SystemTime: TSystemTime;
begin
GetLocalTime(SystemTime);
Result := datetimetostr(SystemTimeToDateTime(SystemTime));
end;

procedure TForm5.addClick(Sender: TObject);
var
i,n,a:integer;
begin

//校正时间格式
if hour.text='' then hour.Text:='0';
if hour.Text='00' then hour.text:='0';
//一位转两位数
for a:=0 to 9 do
if strtoint(min.text)=a then min.text:='0'+inttostr(a);
//一位转两位数
for a:=0 to 9 do
if strtoint(sec.text)=a then sec.text:='0'+inttostr(a);

timer1.Enabled:=true;
SetTime_str:=DateToStr(datetimepicker1.Date)+' '+hour.Text+':'+min.Text+':'+sec.Text;
SetTime:=StrToDateTime(SetTime_str);
if SetTime>now then//检查添加时间是否小于现在
begin//检查添加时间
if listbox1.Items.Count<>0 then//list不为空的情况
begin  //if的开始
for n:=listbox1.Items.Count-1 downto 0 do  //检索listbox有没有重复，没有重复就添加listbox和注册表
begin //第一个检索的for
if listbox1.Items.Strings[n]=SetTime_str then begin showmessage('已增加过该日程');break;end;
listbox1.Items.Append(SetTime_str);
context[listbox1.Items.Count]:=edit1.text;  //根据count自身的计数，来自动递增context的数组
sort[listbox1.Items.Count]:=combobox1.Text;  //根据count自身的计数，来自动递增context的数组
//添加注册表日程
reg:=Tregistry.Create;
reg.RootKey:=HKEY_LOCAL_MACHINE;
if reg.OpenKey('SOFTWARE/myclock/calendar',true) then
for i:=1 to 50 do
if reg.Readstring(inttostr(i))='' then
begin
reg.Writestring(inttostr(i),SetTime_str); //写入日程时间
reg.WriteString('context'+inttostr(i),edit1.Text); //写入日程内容
reg.WriteString('sort'+inttostr(i),combobox1.Text); //写入日程内容
break;end;
break;end;//第一个检索的for
end //if的结束
else // list为空的情况
for n:=listbox1.Items.Count downto 0 do  //检索listbox有没有重复，没有重复就添加listbox和注册表
begin //第二个检索的for
listbox1.Items.Append(SetTime_str);
context[listbox1.Items.Count]:=edit1.text;
sort[listbox1.Items.Count]:=ComboBox1.Text;
//添加注册表日程
reg:=Tregistry.Create;
reg.RootKey:=HKEY_LOCAL_MACHINE;
if reg.OpenKey('SOFTWARE/myclock/calendar',true) then
for i:=1 to 50 do
if reg.Readstring(inttostr(i))='' then
begin //AA
reg.Writestring(inttostr(i),SetTime_str); //写入日程时间
reg.WriteString('context'+inttostr(i),edit1.Text); //写入日程内容
reg.WriteString('sort'+inttostr(i),combobox1.Text); //写入日程内容
break;end;//AA
break;end;//第二个检索的for
end//检查添加时间结束
else
showmessage('添加日程小于当前时间');
end; //procedure

procedure TForm5.delClick(Sender: TObject);
var
i,j:integer;
begin
//删除注册表日程
reg:=Tregistry.Create;
reg.RootKey:=HKEY_LOCAL_MACHINE;
if reg.OpenKey('software/myclock/calendar',true) then
for i:=1 to 50 do
for j:=listbox1.Items.Count-1 downto 0 do
if listbox1.Selected[j] then
if reg.ReadString(inttostr(i))=listbox1.Items.Strings[j] then   //检查注册表日程等于list日程
begin //AA
reg.DeleteValue(inttostr(i));
reg.DeleteValue('context'+inttostr(i));
reg.DeleteValue('sort'+inttostr(i));
reg.CloseKey;
end;  //AA
ListBox1.Items.Clear; //清空listbox1
FormCreate(form5);  //重新调用formcreate来建立listbox1
end;

 

 

procedure TForm5.hourEnter(Sender: TObject);
begin
updown1.Associate:=hour;
end;

procedure TForm5.secEnter(Sender: TObject);
begin
updown1.Associate:=sec;
end;

procedure TForm5.minEnter(Sender: TObject);
begin
updown1.Associate:=min;
end;

procedure TForm5.minChange(Sender: TObject);
begin
if strtoint(min.text)>59 then min.text:='00';
if strtoint(min.text)<0 then min.text:='59';
end;

procedure TForm5.secChange(Sender: TObject);
begin
if strtoint(sec.text)>59 then sec.text:='00';
if strtoint(sec.text)<0 then sec.text:='59';
end;

procedure TForm5.ListBox1DblClick(Sender: TObject);
var
i:integer;
begin
for i:=listbox1.Items.Count-1 downto 0 do
if listbox1.Selected[i] then
showmessage('第'+inttostr(i+1)+'条日程内容是：'+context[i+1]+'。'+#13+'提醒类型是：'+sort[i+1]);
end;

procedure TForm5.FormCreate(Sender: TObject);
var
i,n:integer;
begin
verify:=true;
DateTimePicker1.DateTime:=date;
n:=0;
reg:=Tregistry.Create;
reg.RootKey:=HKEY_LOCAL_MACHINE;
if reg.OpenKey('software/myclock/calendar',true) then
for i:=1 to 50 do
if reg.ReadString(inttostr(i))<>'' then
if strtodatetime(reg.ReadString(inttostr(i)))<now then  //检查注册表日程小等list日程
begin //AA
showmessage('该日程已过期：'+reg.ReadString(inttostr(i)));
reg.DeleteValue(inttostr(i));
reg.DeleteValue('context'+inttostr(i));
reg.DeleteValue('sort'+inttostr(i));
end;  //AA
for i:=1 to 50 do
if reg.ReadString(inttostr(i))<>'' then
begin //if的begin
listbox1.Items.Append(reg.ReadString(inttostr(i)));
inc(n);
context[n]:=reg.ReadString('context'+inttostr(i));
sort[n]:=reg.ReadString('sort'+inttostr(i));
end; //if的end
if listbox1.Items.Count=0 then timer1.Enabled:=false; //如果list为空就关闭timer1
end;

procedure delreg(i:integer);
begin
reg:=Tregistry.Create;
reg.RootKey:=HKEY_LOCAL_MACHINE;
if reg.OpenKey('software/myclock/calendar',true) then
reg.DeleteValue(inttostr(i));
reg.DeleteValue('context'+inttostr(i));
reg.DeleteValue('sort'+inttostr(i));
form5.ListBox1.Items.Clear; //清空listbox1
form5.FormCreate(form5);  //重新调用formcreate来建立listbox1
end;

procedure CheckPassTime;
var
i:integer;
begin
reg:=Tregistry.Create;
reg.RootKey:=HKEY_LOCAL_MACHINE;
if reg.OpenKey('software/myclock/calendar',true) then
for i:=1 to 50 do
if strtodatetime(reg.ReadString(inttostr(i)))<now then   //检查注册表日程等于list日程
begin //AA
reg.DeleteValue(inttostr(i));
reg.DeleteValue('context'+inttostr(i));
reg.DeleteValue('sort'+inttostr(i));
reg.CloseKey;
end;  //AA
form5.ListBox1.Items.Clear; //清空listbox1
form5.FormCreate(form5);  //重新调用formcreate来建立listbox1
verify:=false;
end;  //procedure

 

procedure TForm5.Timer1Timer(Sender: TObject);
var
n,j:integer;
begin
j:=listbox1.Items.Count;
if j<>0 then  //检查list是否为空
begin  //AA
for n:=j-1 downto 0 do   //依次读取listbox里面的日期
 if listbox1.Items.Strings[n]=GetCurrentDateTime then  //如果读取的日期等于现在的
begin application.BringToFront;//提醒过程开始
verify:=false;  //停止查检过期时间

if sort[n+1]='静声提醒' then
begin
MessageBox(application.Handle, pchar(context[n+1]){提醒的内容} ,'无敌小闹钟提醒', mb_OK);
delreg(n+1);
end;

if sort[n+1]='铃声提醒' then
begin //EE
  if sets.setting.CheckBoxRing.Checked=true then sets.setting.MPEGPlayer1.Play
  else
  form1.Timer_wav.Enabled:=true;
if MessageBox(application.Handle,pchar(context[n+1]),'无敌小闹钟提醒', mb_OK)=1 then
form1.Timer_wav.Enabled:=False;
if sets.setting.CheckBoxRing.Checked=true then sets.setting.MPEGPlayer1.stop;
delreg(n+1);
end; //EE

if sort[n+1]='无敌闹钟' then
begin //BB
if sets.setting.CheckBoxRing.Checked=true then sets.setting.MPEGPlayer1.play
else
begin  //DD
form1.Timer_restart.Enabled:=true;
form1.Timer_wav.Enabled:=true;
end;  //DD
if MessageBox(application.Handle,'您设置的时间到了','无敌小闹钟提醒', mb_OK)=1 then
form1.Timer_restart.Enabled:=False;
form1.Timer_wav.Enabled:=False;
if sets.setting.CheckBoxRing.Checked=true then sets.setting.MPEGPlayer1.stop;
delreg(n+1);
end;// BB

if sort[n+1]='立刻关机' then
begin  //CC
delreg(n+1);
winexec('shutdown -t 0 -s',SW_Normal);
Application.Terminate;
end; //CC
verify:=true;   //开始检查过期时间
end//提醒过程结束
{
else
if (verify=true) and (strtodatetime(listbox1.Items.Strings[n])<now) then // 检查列表日期是否过期
begin //DD
  timer1.Enabled:=false;
  if MessageBox(application.Handle,pchar('日程已过期，内容是：' + context[n+1]),'无敌小闹钟提醒', mb_OK)=1 then
  begin
  timer1.Enabled:=true;
  delreg(i);
  end;
 end;//DD    }
end //AA
else timer1.Enabled:=false;  //如果list为空就关闭timer1

end;  //procedure

 

procedure TForm5.hourChange(Sender: TObject);
begin
if strtoint(hour.text)>23 then hour.text:='0';
if strtoint(hour.text)<0 then hour.text:='23';
end;

procedure TForm5.hourKeyPress(Sender: TObject; var Key: Char);
begin
if not (key in ['0'..'9']) then key:=#0;
end;

procedure TForm5.minKeyPress(Sender: TObject; var Key: Char);
begin
if not (key in ['0'..'9']) then key:=#0;
end;

procedure TForm5.secKeyPress(Sender: TObject; var Key: Char);
begin
if not (key in ['0'..'9']) then key:=#0;
end;

procedure TForm5.hourClick(Sender: TObject);
begin
hour.SelectAll;
end;

procedure TForm5.minClick(Sender: TObject);
begin
min.SelectAll;
end;

procedure TForm5.Edit1Click(Sender: TObject);
begin
Edit1.SelectAll;
end;

procedure TForm5.secClick(Sender: TObject);
begin
sec.SelectAll;
end;

procedure TForm5.LabelDateClick(Sender: TObject);
begin
labeldate.Visible:=false;
datetimepicker1.Visible:=true;
end;

procedure TForm5.LabelTimeClick(Sender: TObject);
begin
labeltime.Visible:=false;
panel1.Visible:=true;
end;

procedure TForm5.LabelContextClick(Sender: TObject);
begin
labelcontext.Visible:=false;
edit1.Visible:=true;
end;

procedure TForm5.LabelWorkClick(Sender: TObject);
begin
labelwork.Visible:=false;
combobox1.Visible:=true;
end;

end.

 

 

--------------------------------

 

 

unit sets;

interface

uses              
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, registry, StdCtrls,  MPEGPlay;

type
  Tsetting = class(TForm)
   
    Label1: TLabel;
    Edit2: TEdit;
    Label2: TLabel;
    Label4: TLabel;
    CheckBoxRing: TCheckBox;
    OpenDialog1: TOpenDialog;
    MPEGPlayer1: TMPEGPlayer;
    buttonopen: TButton;
    buttonplay: TButton;
    buttonstop: TButton;
    Button1: TButton;
    Label3: TLabel;
    Label5: TLabel;
    CheckBoxPW: TCheckBox;
    Label6: TLabel;
    Label7: TLabel;
    CheckBoxShut: TCheckBox;
    procedure FormCreate(Sender: TObject);
    procedure buttonopenClick(Sender: TObject);
    procedure buttonplayClick(Sender: TObject);
    procedure buttonstopClick(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure Label6Click(Sender: TObject);
    procedure Edit2KeyPress(Sender: TObject; var Key: Char);
    procedure Edit2Click(Sender: TObject);

    procedure CheckBoxPWClick(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);

  private

  public

  end;

var
  setting: Tsetting;
  reg:TRegistry;
implementation

uses Unit1;

{$R *.dfm}

function encrypt(original:string):string;   //加密
var
i,j:integer;
temp:string[1];
encrypted:string;
begin
for i:=1 to length(original) do
begin //for
temp:=copy(original,i,1);
j:=ord(temp[1])+3;//得到的字符加1
encrypted:=encrypted+chr(j);
end; //for
result:=encrypted;
end;

function decrypt(encrypted:string):string;   //解密
var
i,j:integer;
temp:string[1];
original:string;
begin
for i:=1 to length(encrypted) do
begin //for
temp:=copy(encrypted,i,1);
j:=ord(temp[1])-3;//得到的字符加1
original:=original+chr(j);
end; //for
result:=original;
end;

procedure Tsetting.FormCreate(Sender: TObject);
var
filepath:string;
second:string;
message1:string;
custom1:string;
isPW:string;
Shut:string;
begin
//读取注册表
reg:=TRegistry.Create;
reg.RootKey:=HKEY_LOCAL_MACHINE;
if reg.OpenKey('software/myclock',false) then
filepath:=reg.ReadString ('path');   //读入MP3的路径
second:=reg.ReadString('playsecond'); //读入响铃时间
if second='' then second:='60';  //防止second为空
message1:=reg.ReadString('message');  //读入提醒内容
if message1='' then message1:='您设置的时间到了';
custom1:=reg.ReadString('customring'); //读入是否自义铃声
isPW:=reg.ReadString('isPW'); //读入是否密码保护
Shut:=reg.ReadString('Shut'); //读入是否阻止关机
reg.CloseKey;

if filepath<>'' then //播放的文件路径
if FileExists(filepath) then
begin
MPEGPlayer1.streamname:=filepath;
buttonplay.Enabled:=true;
checkboxring.Enabled:=true;
end;

edit2.Text:=second;  //播放时间

if custom1='1' then
checkboxring.Checked:=true
else
checkboxring.Checked:=false;
if isPW='1' then
checkboxPW.Checked:=true
else
checkboxPW.Checked:=false;

if shut='1' then
checkboxShut.Checked:=true
else
checkboxShut.Checked:=false;

  MPEGPlayer1.pathtodll:=''; //调入DLL的路径
MPEGPlayer1.init;
  OpenDialog1.Filter:='Mpeg Files(*.mp3)|*.mp3';
  OpenDialog1.Filter:=setting.OpenDialog1.Filter+'|'
               +'All Files(*.*)|*.*';
end;

procedure Tsetting.buttonopenClick(Sender: TObject);
begin
if not opendialog1.Execute then
begin
exit;
checkboxring.Enabled:=false;
end;
checkboxring.Enabled:=true;
buttonplay.Enabled:=true;
MPEGPlayer1.streamname:=opendialog1.filename;

end;

procedure Tsetting.buttonplayClick(Sender: TObject);
begin
mpegplayer1.Play;
buttonplay.Enabled:=false;
buttonstop.Enabled:=true;
end;

procedure Tsetting.buttonstopClick(Sender: TObject);
begin
buttonplay.Enabled:=true;
buttonstop.Enabled:=false;
mpegplayer1.Stop;
end;

procedure Tsetting.Button1Click(Sender: TObject);
begin
if buttonstop.Enabled=true then mpegplayer1.Stop;
buttonstop.Enabled:=false;
buttonplay.Enabled:=true;

//写入注册表
reg:=TRegistry.Create;
reg.RootKey:=HKEY_LOCAL_MACHINE;
if reg.OpenKey('software/myclock',true) then
if opendialog1.FileName<>'' then
reg.WriteString ('path',opendialog1.FileName)
else
reg.WriteString('playsecond',edit2.Text);  //写入时间

if checkboxring.Checked=true then   //写入是否自定义
reg.WriteString('customring','1')
else
reg.WriteString('customring','0');

if checkboxPW.Checked=true then    //写入是否密码保护
reg.WriteString('isPW','1')
else
reg.WriteString('isPW','0');

if checkboxShut.Checked=true then    //写入是否阻止关机
reg.WriteString('Shut','1')
else
reg.WriteString('Shut','0');
close;
end;

 

procedure Tsetting.Label6Click(Sender: TObject);
var
PW:string;
begin //procedure
reg:=TRegistry.Create;
reg.RootKey:=HKEY_LOCAL_MACHINE;
if reg.OpenKey('software/myclock',true) then
pw:=decrypt(reg.ReadString('Password'));//得到数据后先解密

if pw='' then   //没设过密码的情况
begin //B
pw:=(InputBox('无敌小闹钟', '输入新密码　', ''));
if pw=(InputBox('无敌小闹钟', '再次输入　', '')) then
reg.WriteString('password',encrypt(pw)) //写数据之前先加密
else
showmessage('两次输入密码不一致');

end//B
else

if pw<>InputBox('无敌小闹钟', '输入旧密码　', '') then showmessage('密码错误')
else
begin //B
pw:=InputBox('无敌小闹钟', '输入新密码　', '');
if pw=InputBox('无敌小闹钟', '再次输入　', '') then
reg.WriteString('password',encrypt(pw))
else
showmessage('两次输入密码不一致');
end;//B
end; //procedure

procedure Tsetting.Edit2KeyPress(Sender: TObject; var Key: Char);
begin
if not (key in ['0'..'9']) then key:=#0;
end;

procedure Tsetting.Edit2Click(Sender: TObject);
begin
Edit2.SelectAll;
end;

 

procedure Tsetting.CheckBoxPWClick(Sender: TObject);
begin
if checkboxPW.Checked=true then
begin  //if
reg:=TRegistry.Create;
reg.RootKey:=HKEY_LOCAL_MACHINE;
if reg.OpenKey('software/myclock',true) then
if reg.ReadString('Password')='' then  Label6Click(self);
end;  //if
end;

procedure Tsetting.FormClose(Sender: TObject; var Action: TCloseAction);
begin
reg.CloseKey;
end;

end.

 

 

 

-----------------------

 

 

unit MPEGPlay;

interface

uses
  Windows, Messages, SysUtils, Classes, ExtCtrls;

type ErrString = array[0..5] of string[50];

const plmOpened  = 0;
      plmReady   = 1;
      plmStopped = 2;
      plmPlaying = 3;
      plmPaused  = 4;

const  ErrStr : ErrString = ('MPEG library not loaded',
                             'Internal decoder error',
                             'Incorrect mode',
                             'Input stream error',
                             'Input stream is non-seekable',
                             'Output device failure');

type TMPEGError = class (Exception)
                  public
                    ErrCode : byte;
                    Constructor CreateErr(Mess:string; Err:byte);
                  end;

type TMPEGPlayer = class;

     MPInitProc = function:integer; stdcall;
     MPCMProc   = function:boolean; stdcall;
     MPOFNProc  = function (mode:integer; value:pchar):boolean; stdcall;
     MPSVProc   = function (value:integer):boolean; stdcall;
     MPPProc    = function (sp, ep :integer; v:pointer):integer; stdcall;
     MPDProc    = function (value:boolean):boolean; stdcall;
     MPFProc    = function:single; stdcall;
     CBCSProc   = procedure (obj:TMPegPlayer; var cant_seek:boolean; var res:pointer); stdcall;
     CBClSProc  = (*ResCloseStream*)procedure (obj:TMPegPlayer; handle :pointer); stdcall;
     CBRSSProc  = (*ResRestartStream*)procedure (obj:TMPegPlayer; handle :pointer; var res:boolean); stdcall;
     CBRSProc   = (*ResReadStream*) procedure(obj:TMPegPlayer; handle:pointer;
                                        var read_buffer;
                                        nNumberOfBytesToRead:longInt;
                                        var nNumberOfBytesRead:longInt;var res:boolean); stdcall;
     CBRSPProc  = (*ResSetPointer*)procedure(obj:TMPegPlayer; handle:pointer;
                                            NumBytes,MoveMethod:LongInt;var res:LongInt); stdcall;
     CBGSProc   = (*ResGetSize*) procedure (obj:TMPegPlayer; handle:pointer; var res:longint); stdcall;
     MPSISProc  = function (value:pchar;
                            from_res:boolean;
                            CBCS:CBCSProc;
                            CBClS:CBClSProc;
                            CBRSS:CBRSSProc;
                            CBRS:CBRSProc;
                            CBRSP:CBRSPProc;
                            CBGS:CBGSProc;opps:pointer):boolean; stdcall;

  TPlayPriority = (Idle,Lowest,BelowNormal,Normal,AboveNormal, Highest, TimeCritical);
  TOutputDevice = (wavemapper, pcmfile);

     TOpenStreamEvent = procedure (var Nonseekable:boolean; var Context:pointer) of object;
     // Event must return context, that will be passes to other stream-handling
     // functions
     // if the event fails, it returns nil
     TCloseStreamEvent = procedure (Context:pointer) of object;
     TRestartStreamEvent = procedure (Context:pointer; var res:boolean) of object;
     TReadStreamEvent = procedure (Context:pointer;var read_buffer;
                                   nNumberOfBytesToRead:LongInt;
                                   var nNumberOfBytesRead:LongInt; var res:boolean) of object;
     TSeekStreamEvent = procedure (Context:pointer; numbytes:LongInt;MoveMethod:LongInt; var res:LongInt) of object;
     // MoveMethod can be next:
     // FILE_BEGIN = 0;
     // FILE_CURRENT = 1;
     // FILE_END = 2;
     TGetStreamSizeEvent = procedure (Context:pointer; var res: longint) of object;
     TPosUpdateEvent = procedure (Pos,Len:longint) of object;

  TMPEGPlayer = class(TComponent)
  private
    DLLHandle    : THandle;
    FDLLPath     : string;
    FStreamName  : String;
    FOutFilename : string;
    FOutputDevice: integer;
    FStartPos    : integer;
    FEndPos      : integer;
    FOpened      : boolean;
    FPlayStarted : boolean;
    FPaused      : boolean;
    FPlayStopped : boolean;
    FAutoPlay    : boolean;
    FPriority    : integer;
    FSeekable    : boolean;
    FResource    : boolean;
    FUseTimer    : boolean;
    FTimerFreq   : integer;
    FPlayCount   : integer;
    PosUpdateTimer : TTimer;
    FOnPosUpdate : TPosUpdateEvent;
    FOnPlayEnd   : TNotifyEvent;
    FOpenEvent   : TOpenStreamEvent;
    FCloseEvent  : TCloseStreamEvent;
    FRestartEvent: TRestartStreamEvent;
    FGetSizeEvent: TGetStreamSizeEvent;
    FSeekEvent   : TSeekStreamEvent;
    FReadEvent   : TReadStreamEvent;
    FStreamLength : longint;

    {Dll Prodecures}
    DllInit            : MPCMProc;
    DllDeInit          : MPInitProc;
    DllOpen            : MPSISProc;
    DllPause           : MPDProc;
    DllStop            : MPCMProc;
    DllPlay            : MPPProc;
    DLLRestart         : MPCMProc;
    DllSetPriority     : MPSVProc;
    DllSetOutputDevice : MPOFNProc;
    DllClose           : MPCMProc;
    DllGetFrequency    : MPInitProc;
    DllGetBitRate      : MPInitProc;
    DllGetLayer        : MPInitProc;
    DllGetPlayerMode   : MPInitProc;
    DllGetCurrentPos   : MPInitProc;
    DllGetLength       : MPInitProc;
    DllResetPlayerMode : MPCMProc;
    DllSeek            : MPSVProc;
    DLLLastError       : MPInitProc;

    LE:integer;
    function LastError:integer;
    function GetLoaded:boolean;

    procedure SetOutFilename(value:string);

    procedure SetOutputDevice(value:TOutputDevice);
    function GetOutputDevice:TOutputDevice;

    procedure SetTimerFreq(value:integer);

  protected

    function GetPosition:integer;
    function GetPlayMode:integer;
    function GetFrequency:integer;
    function GetBitrate:integer;
    function GetLayer:integer;
    function GetLength:integer;
    procedure SetStreamName(value:string);
    procedure Seek(value:integer);
    function GetPlayStopped:boolean;
    procedure Pause(value:boolean);
    function  GetPriority:TPlayPriority;
    procedure SetPriority(P:TPlayPriority);
    procedure UpdateTimer(Sender: TObject); virtual;

  public
    constructor Create(AOwner:TComponent); override;
    destructor Destroy; override;
    procedure Init;
    procedure Play;
    procedure Restart;
    procedure Stop;
    procedure Open;
    procedure Close;
    procedure Deinit;
    property Paused : boolean read FPaused write Pause;
    property CurrentPosition : integer read GetPosition write Seek;
    property Mode : integer read GetPlayMode;
    property Frequency : integer read GetFrequency;
    property Bitrate : integer read GetBitrate;
    property Layer : integer read GetLayer;
    property PlayStopped : boolean read GetPlayStopped;
    property Length : integer read FStreamLength;
    property DLLLoaded : boolean read GetLoaded;

  published
    property Seekable : boolean read FSeekable write FSeekable;
    property FromStream : boolean read FResource write FResource;
    property PlayerPriority : TPlayPriority read GetPriority write SetPriority;
    property UseTimer : boolean read FUseTimer write FUseTimer;
    property TimerFreq : integer read FTimerFreq write SetTimerFreq;
    property AutoPlay : boolean read FAutoPlay write FAutoPlay;
    property StreamName : String read FStreamName write SetStreamName;
    property OutputDevice: TOutputDevice read GetOutputDevice write SetOutputDevice;
    property OutFilename: string read FOutFilename write SetOutFilename;
    property PathToDLL : String read FDLLPath write FDLLPath;
    property StartPos : integer read FStartPos write FStartPos;
    property EndPos : integer read FEndPos write FEndPos;
    property PlayedXTimes : integer read FPlayCount;

    property OnOpenStream : TOpenStreamEvent read FOpenEvent write FOpenEvent;
    property OnCloseStream: TCloseStreamEvent read FCloseEvent  write FCloseEvent;
    property OnRestartStream: TRestartStreamEvent read FRestartEvent  write FRestartEvent;
    property OnGetStreamSize: TGetStreamSizeEvent read FGetSizeEvent write FGetSizeEvent;
    property OnSeekStream : TSeekStreamEvent read FSeekEvent write FSeekEvent;
    property OnReadStream : TReadStreamEvent read FReadEvent write FReadEvent;

    property OnPosUpdate:TPosUpdateEvent read FOnPosUpdate write FOnPosUpdate;
    property OnPlayEnd : TNotifyEvent read FOnPlayEnd write FOnPlayEnd;
  end;

procedure Register;

implementation

Constructor TMPEGError.CreateErr;
begin
  inherited Create(Mess);
  ErrCode:=Err;
end;

procedure CBCS (obj:TMPegPlayer; var cant_seek:boolean; var res:pointer); stdcall;
begin
  if Assigned(Obj.OnOpenStream) then Obj.OnOpenStream(cant_seek, res) else
     res:=nil;
end;

procedure CBClS (obj:TMPegPlayer; handle :pointer); stdcall;
begin
  if Assigned(Obj.OnCloseStream) then Obj.OnCloseStream(handle);
end;

procedure CBRSS (obj:TMPegPlayer; handle :pointer; var res : boolean); stdcall;
begin
  if Assigned(Obj.OnRestartStream) then Obj.OnRestartStream(handle, res)
  else res:=false;
end;

procedure CBRS (obj:TMPegPlayer; handle:pointer;
                   var read_buffer;
                   nNumberOfBytesToRead:longint;
                   var nNumberOfBytesRead:longInt; var res:boolean); stdcall;
begin
  if Assigned(Obj.OnReadStream) then Obj.OnReadStream(handle,read_buffer,nNumberOfBytesToRead,nNumberOfBytesRead,res) else
  res:=false;
end;

procedure CBRSP (obj:TMPegPlayer; handle:pointer;
                        NumBytes,MoveMethod:LongInt; var res:LongInt); stdcall;
begin
  if Assigned(Obj.OnSeekStream) then Obj.OnSeekStream(handle,NumBytes,MoveMethod, res) else
     res:=-1;
end;

procedure CBGS (obj:TMPegPlayer; handle:pointer; var res:longint); stdcall;
begin
  if Assigned (Obj.OnGetStreamSize) then Obj.OnGetStreamSize(handle,res) else res:=-1;
end;

function TMPEGPlayer.LastError;
begin
  if (@DLLLastError<>nil) then
    result:=DLLLastError else
    result:=0;
end;

function TMPEGPlayer.GetLoaded;
begin
  result:=DLLHandle<>0;
end;

constructor TMPEGPlayer.Create;
begin
  inherited Create(AOwner);
  FPlayStopped := false;
  FPlayStarted := false;
end;

destructor TMPEGPlayer.Destroy;
begin
  PosUpdateTimer.free;
  inherited Destroy;
end;

procedure TMPEGPlayer.UpdateTimer(Sender: TObject);
var
  l:longint;
begin
  if not(FOpened) or not(FPlayStarted) then
  begin
    PosUpdateTimer.Enabled := false;
    exit;
  end;
  l := CurrentPosition;
  if l>FStreamLength then l := 0;
  if assigned(FOnPosUpdate) then FOnPosUpdate(l,FStreamLength);
  if FPlayStopped then
  begin
    PosUpdateTimer.Enabled := false;
    FPlayStarted := false;
    if assigned(FOnPlayEnd) then
    begin
      FPlayStopped := false;
      FOnPlayEnd(Self);
    end;
  end;
end;

procedure TMPEGPlayer.Init;
var s:string;

begin
  s:=FDLLPath;
  if (FDLLPath<>'') and (FDLLPath[system.Length(FDLLPath)]<>'/')
  and (FDLLPath[system.Length(FDLLPath)]<>':') then s:=s+'/';
    s:=s+'mpegdll'#0;
  DLLHandle:=LoadLibrary(@S[1]);
  if DLLHandle=0 then Raise TMPEGError.Create('Can''t load MPEG library');
  @DllInit            :=GetProcAddress(DLLHandle,'init');
  @DllDeInit          := GetProcAddress(DLLHandle,'deinit');
  @DllOpen            := GetProcAddress(DLLHandle,'Open');
  @DllPause           := GetProcAddress(DLLHandle,'Pause');
  @DllRestart         := GetProcAddress(DLLHandle,'Restart');
  @DllStop            := GetProcAddress(DLLHandle,'Stop');
  @DllSetPriority     := GetProcAddress(DLLHandle,'SetPriority');
  @DllSetOutputDevice := GetProcAddress(DLLHandle,'SetOutputDevice');
  @DllPlay            := GetProcAddress(DLLHandle,'Play');
  @DllClose           := GetProcAddress(DLLHandle,'Close');
  @DllGetFrequency    := GetProcAddress(DLLHandle,'GetFrequency');
  @DllGetBitRate      := GetProcAddress(DLLHandle,'GetBitrate');
  @DllGetLayer        := GetProcAddress(DLLHandle,'GetLayer');
  @DllGetPlayerMode   := GetProcAddress(DLLHandle,'GetPlayerMode');
  @DllGetCurrentPos   := GetProcAddress(DLLHandle,'GetCurrentPos');
  @DllGetLength       := GetProcAddress(DLLHandle,'GetLength');
  @DllResetPlayerMode := GetProcAddress(DLLHandle,'ResetPlayerMode');
  @DllSeek            := GetProcAddress(DLLHandle,'Seek');
  @DLLLastError       := GetProcAddress(DLLHandle,'LastError');

  if (@DllInit=nil)
  or (@DllDeInit=nil)
  or (@DllOpen=nil)
  or (@DllPause=nil)
  or (@DllRestart=nil)
  or (@DllStop=nil)
  or (@DllSetPriority=nil)
  or (@DllSetOutputDevice=nil)
  or (@DllPlay=nil)
  or (@DllClose=nil)
  or (@DllGetFrequency=nil)
  or (@DllGetBitRate=nil)
  or (@DllGetLayer=nil)
  or (@DllGetPlayerMode=nil)
  or (@DllGetCurrentPos=nil)
  or (@DllGetLength=nil)
  or (@DllResetPlayerMode=nil)
  or (@DllSeek=nil)
  or (@DLLLastError=nil)
  then begin
    FreeLibrary(DLLHandle);
    DLLHandle:=0;
    Raise TMPEGError.CreateErr(ErrStr[0],0);
  end;
  if DllInit=false then
  begin
    LE:=LastError;
    DLLHandle:=0;
    Raise TMPEGError.CreateErr(ErrStr[LE],LE);
  end;
  PosUpdateTimer := TTimer.create(self);
  PosUpdateTimer.OnTimer := UpdateTimer;
  PosUpdateTimer.Enabled := false;
  PosUpdateTimer.Interval := TimerFreq;
  if not UseTimer then PosUpdateTimer.Interval := 0;
  FStreamLength := 0;
end;

procedure TMPEGPlayer.Deinit;
begin
  if DLLHandle=0 then Raise TMPEGError.CreateErr(ErrStr[0],0);
  if FOpened then Close;
  if @DLLDeInit<>nil then DLLDeInit;
  FreeLibrary(DLLHandle);
  DLLHandle:=0;
  @DllInit            := nil;
  @DllDeInit          := nil;
  @DllOpen            := nil;
  @DllPause           := nil;
  @DLLRestart         := nil;
  @DllStop            := nil;
  @DllSetPriority     := nil;
  @DllSetOutputDevice := nil;
  @DllPlay            := nil;
  @DllClose           := nil;
  @DllGetFrequency    := nil;
  @DllGetBitRate      := nil;
  @DllGetLayer        := nil;
  @DllGetPlayerMode   := nil;
  @DllGetCurrentPos   := nil;
  @DllGetLength       := nil;
  @DllResetPlayerMode := nil;
  @DllSeek            := nil;
  @DLLLastError       := nil;
end;

procedure TMPEGPlayer.Open;
var p:pchar;

begin
  if DLLHandle=0 then Raise TMPEGError.CreateErr(ErrStr[0],0);
  if FOpened then Close;
  FOpened := false;

    if FResource then
    begin
      DLLOpen(nil,true,CBCS,CBClS,CBRSS,CBRS,CBRSP,CBGS,self);
      LE:=LastError;
    end
    else
    begin
      if FStreamName = '' then
         Raise TMPEGError.CreateErr('Can''t play non-specified stream',254);

      GetMem(p,512);
      StrPCopy(p,FStreamName);
      DLLOpen(p, false, nil,nil,nil,nil,nil,nil,nil);
      LE:=LastError;
      FreeMem(p,512);
    end;
    if LE>0 then
      Raise TMPEGError.CreateErr(ErrStr[LE],LE);
    FOpened:=true;
    FPlayCount:=1;
    FStreamLength:=GetLength;
    if AutoPlay then Play;
end;

procedure TMPEGPlayer.Pause(value:boolean);
begin
  if DLLHandle=0 then Raise TMPEGError.CreateErr(ErrStr[0],0);
  if not(FPlayStarted) or (FPlayStopped) then
  begin
    FPaused := false;
    if value then Raise TMPEGError.CreateErr(ErrStr[2],2);
    exit;
  end;
    DLLPause(not value);
    LE:=LastError;
    if LE>0 then Raise TMPEGError.CreateErr(ErrStr[LE],LE);
    FPaused:=value;
end;

procedure TMPEGPlayer.Stop;
begin
  if not(FPlayStarted) or (FPlayStopped) then
    Raise TMPEGError.CreateErr(ErrStr[2],2);
  if DLLHandle=0 then Raise TMPEGError.CreateErr(ErrStr[0],0);
    DLLStop;
    LE:=LastError;
    if LE>0 then Raise TMPEGError.CreateErr(ErrStr[LE],LE);
    FPlayStarted := false;
    FPaused:=false;
end;

procedure TMPEGPlayer.Restart;
begin
  if DLLHandle=0 then Raise TMPEGError.CreateErr(ErrStr[0],0);
  if not FOpened then Raise TMPEGError.CreateErr(ErrStr[2],2);
  FPlayStopped:=false;
  DllRestart;
  LE:=LastError;
  if LE>0 then Raise TMPEGError.CreateErr(ErrStr[LE],LE);
  FPlayStarted := true;
  inc(FPlayCount);
  if (UseTimer) and (PosUpdateTimer.Interval<>0) then
  begin
    PosUpdateTimer.Enabled := true;
    UpdateTimer(self);
  end;
end;

procedure TMPEGPlayer.Play;
var p      : pchar;
    b      : integer;

begin
  if DLLHandle=0 then Raise TMPEGError.CreateErr(ErrStr[0],0);
  if FPaused then
  begin
    Pause(false);
    exit;
  end;
  if FPlayStarted then exit;
  if not FOpened then Open;
  if not FOpened then exit;
  if FPlayCount>1 then
  begin
    Restart;
    exit;
  end;
    DLLSetPriority(FPriority);
    LE:=LastError;
    if LE>0 then Raise TMPEGError.CreateErr(ErrStr[LE],LE);

    GetMem(p,260);
    StrPCopy(p,FOutFilename);
    DllSetOutPutDevice(FOutputDevice,p);
    FreeMem(p,260);
    LE:=LastError;
    if (LE>0) then Raise TMPEGError.CreateErr(ErrStr[LE],LE);

    b:=DllPlay(FStartPos, FEndPos,@FPlayStopped);
    LE:=LastError;
    if (LE>0) or (b<>0) then Raise TMPEGError.CreateErr(ErrStr[LE],LE);
    FPlayStarted := true;
    inc(FPlayCount);
    if (UseTimer) and (PosUpdateTimer.Interval<>0) then
    begin
      PosUpdateTimer.Enabled := true;
      UpdateTimer(self);
    end;
end;

procedure TMPEGPlayer.Close;
begin
  if DLLHandle=0 then Raise TMPEGError.CreateErr(ErrStr[0],0);
  FOpened := false;
  FPaused:=false;
  FPlayStarted := false;
  FPlayCount:=0;
  DllClose;
  LE:=LastError;
  if LE>0 then Raise TMPEGError.CreateErr(ErrStr[LE],LE);
end;

function TMPEGPlayer.GetFrequency:integer;
begin
  if DLLHandle=0 then Raise TMPEGError.CreateErr(ErrStr[0],0);
  result:=DLLGetFrequency;
  LE:=LastError;
  if LE>0 then Raise TMPEGError.CreateErr(ErrStr[LE],LE);
end;

function TMPEGPlayer.GetBitrate:integer;
begin
  if DLLHandle=0 then Raise TMPEGError.CreateErr(ErrStr[0],0);
  result:=DLLGetBitrate;
  LE:=LastError;
  if LE>0 then Raise TMPEGError.CreateErr(ErrStr[LE],LE);
end;

function TMPEGPlayer.GetLayer:integer;
begin
  if DLLHandle=0 then Raise TMPEGError.CreateErr(ErrStr[0],0);
    result:=DLLGetLayer;
    LE:=LastError;
    if LE>0 then Raise TMPEGError.CreateErr(ErrStr[LE],LE);
end;

function TMPEGPlayer.GetPlayMode;
begin
  if DLLHandle=0 then Raise TMPEGError.CreateErr(ErrStr[0],0);
    result:=DLLGetPlayerMode;
    LE:=LastError;
    if LE>0 then Raise TMPEGError.CreateErr(ErrStr[LE],LE);
end;

function TMPEGPlayer.GetPosition;
begin
  if DLLHandle=0 then Raise TMPEGError.CreateErr(ErrStr[0],0);
    result:=DLLGetCurrentPos;
    LE:=LastError;
    if LE>0 then Raise TMPEGError.CreateErr(ErrStr[LE],LE);
end;

function TMPEGPlayer.GetLength;
begin
  if DLLHandle=0 then Raise TMPEGError.CreateErr(ErrStr[0],0);
    result:=DLLGetLength;
    LE:=LastError;
    if LE>0 then Raise TMPEGError.CreateErr(ErrStr[LE],LE);
end;

function TMPEGPlayer.GetPlayStopped;
begin
  if DLLHandle=0 then Raise TMPEGError.CreateErr(ErrStr[0],0);
  result:=FPlayStopped;
  if result then
  begin
    result:=DllResetPlayerMode;
    LE:=LastError;
    if LE>0 then Raise TMPEGError.CreateErr(ErrStr[LE],LE);
    FPlayStarted := false;
  end;
end;

procedure TMPEGPlayer.SetStreamName;
begin
  FStreamName:=value;
  if FOpened then Close;
end;

procedure TMPEGPlayer.Seek;
begin
  if DLLHandle=0 then Raise TMPEGError.CreateErr(ErrStr[0],0);
    DLLSeek(value);
    LE:=LastError;
    if LE>0 then Raise TMPEGError.CreateErr(ErrStr[LE],LE);
end;

procedure TMPEGPlayer.SetPriority(P:TPlayPriority);
begin
  case p of
    Idle         : fPriority := THREAD_PRIORITY_IDLE;
    Lowest       : fPriority := THREAD_PRIORITY_LOWEST;
    BelowNormal  : fPriority := THREAD_PRIORITY_Below_Normal;
    Normal       : fPriority := THREAD_PRIORITY_NORMAL;
    AboveNormal  : fPriority := THREAD_PRIORITY_ABOVE_NORMAL;
    Highest      : fPriority := THREAD_PRIORITY_HIGHEST;
    TimeCritical : fPriority := THREAD_PRIORITY_TIME_CRITICAL;
  end;
  if DLLHandle<>0 then
  begin
    DLLSetPriority(FPriority);
    LE:=LastError;
    if LE>0 then Raise TMPEGError.CreateErr(ErrStr[LE],LE);
  end;
end;

function TMPEGPlayer.GetPriority:TPlayPriority;
begin
  case fPriority of
    THREAD_PRIORITY_IDLE          : GetPriority := Idle;
    THREAD_PRIORITY_LOWEST        : GetPriority := Lowest;
    THREAD_PRIORITY_Below_Normal  : GetPriority := BelowNormal;
    THREAD_PRIORITY_NORMAL        : GetPriority := Normal;
    THREAD_PRIORITY_ABOVE_NORMAL  : GetPriority := AboveNormal;
    THREAD_PRIORITY_HIGHEST       : GetPriority := Highest;
    THREAD_PRIORITY_TIME_CRITICAL : GetPriority := TimeCritical;
    else GetPriority := Normal;
  end;
end;

procedure TMPEGPlayer.SetOutFilename;
begin
  FOutFileName:=value;
end;

procedure TMPEGPlayer.SetTimerFreq;
begin
  FTimerFreq:=value;
  if value=0 then UseTimer:=false;
end;

procedure TMPEGPlayer.SetOutputDevice;
begin
  if FOutFilename='' then FOutputDevice:=0 else
  if value=wavemapper then FOutputDevice:=0 else FOutputDevice:=2;
end;

function TMPEGPlayer.GetOutputDevice;
begin
  if FOutputDevice=0 then result:=wavemapper else result:=pcmfile;
end;

procedure Register;
begin
  RegisterComponents('Wabbit''s', [TMPEGPlayer]);
end;

end.

 

--------------------------