我就不整理了,主要是其中关于时间的算法供参考。
如果需要全部源码的朋友请和我联系。
需要一个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.
--------------------------