unit Unit1;

interface

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

type
TForm1 = class(TForm)
Timer1: TTimer;
Button1: TButton;
Button2: TButton;
procedure Timer1Timer(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
private
{ Private declarations }
procedure BeepFor(Tone: word; MSecs: integer);
procedure SlientFor(MSecs: integer); { Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;
function _GetPort(address: word): word;
procedure _SetPort(address, Value: Word);
procedure StartBeep(Freq: Word);
procedure StopBeep;

implementation

{$R *.dfm}

function _GetPort(address: word): word; //获取端口
var
bValue: byte;
begin
asm
mov dx, address
in al, dx
mov bValue, al
end;
Result := bValue;
end;

procedure _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;

procedure StartBeep(Freq: Word); //开始发音,Freq为频率
var
B: Byte;
begin
if Freq > 18 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;

procedure StopBeep; //停止发音
var
Value: Word;
begin
value := _GetPort($61) and $FC;
_SetPort($61, Value);
end;

procedure TForm1.BeepFor(Tone: word; MSecs: integer); //发出不同音调及不同时间长度的声音
var
StartTime: LongInt;
begin
StartBeep(Tone);
StartTime := GetTickCount;
while ((GetTickCount - StartTime) < LongInt(MSecs)) do Application.ProcessMessages;
StopBeep;
end;

procedure TForm1.SlientFor(MSecs: integer); //静音若干时间
var
StartTime: LongInt;
begin
StartTime := GetTickCount;
while ((GetTickCount - StartTime) < LongInt(MSecs)) do
Application.ProcessMessages;
end;

procedure TForm1.Timer1Timer(Sender: TObject);
var Hour, Min, Sec, MSec: word;
begin
if Frac(time * 24) * 3600 < 0.1 then //将捕捉整点时间的精度控制在0.1秒内
begin
Timer1.Enabled := false;
DecodeTime(Time, Hour, Min, Sec, MSec); //将时间解析出小时,分,秒,毫秒
Beepfor(165, 1000); //以下一段Beepfor语句奏响海关报时乐曲
Beepfor(131, 1000);
Beepfor(149, 1000);
Beepfor(98, 1000);
SlientFor(1000);
Beepfor(98, 1000);
Beepfor(149, 1000);
Beepfor(165, 1000);
Beepfor(131, 1000);
SlientFor(1000);
if hour = 0 then hour := 24; //到几点即敲几下钟(零点敲24下)
while hour > 0 do
begin
Beepfor(131, 1000);
SlientFor(1000);
hour := hour - 1
end;
Timer1.Enabled := true;
end;
end;


procedure TForm1.Button1Click(Sender: TObject);
begin
Beepfor(165, 1000); //以下一段Beepfor语句奏响海关报时乐曲
Beepfor(131, 1000);
Beepfor(149, 1000);
Beepfor(98, 1000);
SlientFor(1000);
Beepfor(98, 1000);
Beepfor(149, 1000);
Beepfor(165, 1000);
Beepfor(131, 1000);
SlientFor(1000);

end;

procedure TForm1.Button2Click(Sender: TObject);
begin
Beepfor(000, 1000); //以下一段Beepfor语句奏响海关报时乐曲
Beepfor(262, 1000);
Beepfor(296, 1000);
Beepfor(330, 1000);
Beepfor(349, 1000);
Beepfor(392, 1000);
Beepfor(440, 1000);
Beepfor(494, 1000);
SlientFor(1000);
Beepfor(98, 1000);
Beepfor(149, 1000);
Beepfor(165, 1000);
Beepfor(131, 1000);
SlientFor(1000);
end;

end.


方法2:
procedure TForm1.sd3Click(Sender: TObject);
var
i:integer;

begin
MessageBeep(32);
for i:=0 to 10000 do
begin
MessageBeep(8000*i);
// MessageBeep(2001*i);
// MessageBeep(3002*i);
// MessageBeep(4003*i);
// MessageBeep(5004*i);
// MessageBeep(6005*i);
// MessageBeep(7006*i);
// MessageBeep(8007*i);
end;
end;