http://delphibase.6to23.com有程序下载,源代码如下:
unit main2;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, ComCtrls, ExtCtrls;
type
TForm1 = class(TForm)
btn_beep: TButton;
btn_stop: TButton;
DateTimePicker1: TDateTimePicker;
Timer1: TTimer;
btn_exit: TButton;
btn_start: TButton;
Edit1: TEdit;
procedure btn_beepClick(Sender: TObject);
procedure btn_stopClick(Sender: TObject);
procedure btn_exitClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure btn_startClick(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
function _getport(address:word):word;
procedure _setport(address,value:word);
procedure startbeep(freq:word);
procedure stopbeep;
end;
var
Form1: TForm1;
const
low_freq=40;
high_freq=5000;
implementation
{$R *.DFM}
procedure TForm1.btn_beepClick(Sender: TObject);
var
tone:word;
nowtime:tdatetime;
begin
{ with form1 do
begin
left:=left+1;
top:=top+1;
if left>=378 then left:=303;
if top>=152 then top:=120;
end;}
tone:=1000;
nowtime:=time;
edit1.text:=timetostr(nowtime);
// showmessage(timetostr(nowtime));
//startbeep(tone);
// starttime:=gettickcount;
// while ((gettickcount-starttime)<longint(msees)) do
if timetostr(nowtime)>=timetostr(datetimepicker1.Time) then
begin
startbeep(tone);
application.ProcessMessages ;
end;
// stopbeep;
end;
{---------------------------------_GetPort-------------------
-------------------}
function Tform1._GetPort(address:word):word;
var
bValue: byte;
begin
asm
mov dx, address
in al, dx
mov bValue, al
end;
Result := bValue;
end; { _GetPort }
{----------------------------------_SetPort------------------
--------------------}
procedure Tform1._SetPort(address, Value:Word);
var
bValue: byte;
begin
bValue := Trunc(Value and 255);
asm
mov dx, address
mov al, bValue
out dx, al
end;
end; { _SetPort }
{----------------------------------StartBeep-----------------
---------------------}
procedure Tform1.StartBeep(Freq : Word);
var
B: Byte;
begin
if (Freq >= LOW_FREQ) and (Freq <= HIGH_FREQ)
then
begin
Freq := Word(1193181 div LongInt(Freq));
B := Byte(_GetPort($61));
if (B and 3) = 0
then
begin
_SetPort($61, Word(B or 3));
_SetPort($43, $B6);
end;
_SetPort($42, Freq);
_SetPort($42, Freq shr 8);
end;
end; { StartBeep }
{------------------------------StopBeep----------------------
------------------}
procedure Tform1.StopBeep;
var
Value: Word;
begin
Value := _GetPort($61) and $FC;
_SetPort($61, Value);
end; { StopBeep }
procedure TForm1.btn_stopClick(Sender: TObject);
begin
btn_start.Enabled :=true;
btn_stop.Enabled :=false;
timer1.Enabled :=false;
stopbeep;
end;
procedure TForm1.btn_exitClick(Sender: TObject);
begin
stopbeep;
timer1.Enabled :=false;
close;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
{ with form1 do
begin
left:=303;
top:=120;
end; }
// timer1.Enabled :=false;
end;
procedure TForm1.btn_startClick(Sender: TObject);
begin
timer1.Enabled :=true;
btn_start.Enabled :=false;
btn_stop.Enabled :=true;
end;
end.