让 PC 喇叭呻吟 —— BY CJ(50分)

不很初级，要求
1、SOURCE
2、UNDER NT
3、不要随便给个构件，测试了再告诉我

Try the following code. We use it in a DLL to allow playing the PC speaker on 95 or NT.

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;

function GetPort(address: Word): Word;
var
bValue: Byte;
begin
asm
mov DX, address
in AL, DX
mov bValue, AL
end;
result := bValue;
end;

procedure NoSound;
var
wValue: Word;
begin
wValue := GetPort($61);
wValue := wValue and $FC;
SetPort($61, wValue);
end;

procedure Sound(Freq: Word);
var
B: Word;
begin
if Freq > 18 then begin
Freq := Word(1193181 div LongInt(Freq));

B := GetPort($61);

if (B and 3) = 0 then begin
SetPort($61, B or 3);
{ SetPort($43, $B6);}
end;

SetPort($42, Freq);
SetPort($42, (Freq SHR 8));
end;
end;

procedure Delay(MSecs: Integer);
var
FirstTickCount : LongInt;
begin
FirstTickCount:=GetTickCount;
repeat
SleepEX(1, false); {allowing access to other controls, etc.}
until ((GetTickCount-FirstTickCount) >= LongInt(MSecs));
end;

procedure Play(Freq: Word; MSecs: Integer);
begin
Sound(Freq);
Delay(MSecs);
NoSound;
end;

procedure beepproc(pitch: PLong; time: PLong); cdecl;
begin
if OS.dwOSVersionInfoSize = 0 then begin
OS.dwOSVersionInfoSize := SizeOf(OS);
GetVersionEX(OS);
end;

case OS.dwPlatformId of
VER_PLATFORM_WIN32s : windows.beep(pitch^, time^);
VER_PLATFORM_WIN32_WINDOWS : play(pitch^, time^);
VER_PLATFORM_WIN32_NT : windows.beep(pitch^, time^);
end;
end;



SOURCE 是俺抄自我的NEWS笔记里的， 西西，所以如果CJ问如何让PC喇叭哇哇的哭
或是笑起来，我就不会啦 :-D

Unit BleepInt; { Version 4.3 }

{ Copyright 1999 Andy Preston - Apollo Developments, Swindon U.K. andy@apollod.freeserve.co.uk

How to make your Delphi programs bleep like FRACTINT! See Demo1.pas/Demo1.dfm or Bleepint.htm for details

This unit is free software; you can redistribute it and/or modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version.

This unit is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details.

You should have received a copy of the GNU Library General Public License along with this unit; if not, write to the
Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
}

Interface

Type
TBleepType = (bOK, bInterrupt, bError);

Procedure ShutUp; { Added to help counter the effects of DoBleep (Freq, -1).
If you are producing a tone, & you want to stop without doing another Bleep, call this procedure }

Procedure DoBleep (Freq : Word; MSecs : Integer); { Duration of -1 means bleep until the next bleep sent, or ShutUp is called }

Procedure Bleep (BleepType : TBleepType);

Implementation

Uses
{$IFDEF WIN32} Windows, {$ELSE} WinProcs, {$ENDIF}
{$IFNDEF CONSOLE} Forms; {$ENDIF}

{ -- --- -- --- -- --- -- --- -- --- -- --- -- --- Assembler Bits for Wind 3.x And '95 -- --- -- --- -- --- -- --- -- --- }

Procedure AsmShutUp; {$IFDEF WIN32} Pascal; {$ENDIF}
Begin
Asm
In AL, $61
And AL, $FC
Out $61, AL
End;
End;

Procedure AsmBeep (Freq : Word); {$IFDEF WIN32} Pascal; {$ENDIF}
Label
Skip;
Begin
Asm
Push BX
In AL, $61
Mov BL, AL
And AL, 3
Jne Skip
Mov AL, BL
Or AL, 3
Out $61, AL
Mov AL, $B6
Out $43, AL
Skip: Mov AX, Freq
Out $42, AL
Mov AL, AH
Out $42, AL
Pop BX
End;
End;

{ -- --- -- --- -- --- -- --- -- --- -- --- -- --- Low Level Bits for Wind 3.x And '95 -- --- -- --- -- --- -- --- -- --- }

Procedure HardBleep (Freq : Word; MSecs : Integer);
Var
FirstTickCount : {$IFDEF WIN32} DWord {$ELSE} LongInt {$ENDIF};
Begin
If (Freq>=20) And (Freq<=5000) Then Begin
AsmBeep (Word (1193181 Div LongInt(Freq)));
If MSecs>-1 Then Begin
{ P.Satyanarayana get's a warning under Delphi 4 here 'Comparing signed and unsigned types - widened both operands'
This should be cleared up by the fact that FirstTickCount is now a DWord under Win32
But it does not seem to work - if anyone out there has got D4 and would like to fix it I'll show my eternal gratitude
or at least a mention in the thanks to... section of the HTML file }
FirstTickCount:=GetTickCount;
Repeat
{$IFNDEF CONSOLE} If MSecs>1000 Then Application.ProcessMessages; {$ENDIF}
Until ((GetTickCount-FirstTickCount)>LongInt(MSecs));
AsmShutUp;
End;
End;
End;

{ -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- Procedures for you to use -- --- -- --- -- --- -- --- -- --- -- --- }

Procedure Bleep (BleepType : TBleepType);
Begin
Case BleepType of
bOK: Begin
DoBleep (1047,100);
DoBleep (1109,100);
DoBleep (1175,100);
End;
bInterrupt: Begin
DoBleep (2093,100);
DoBleep (1976,100);
DoBleep (1857,100);
End;
bError: DoBleep (40,500);
End;
End;

{$IFDEF WIN32} Var SysWinNT : Boolean; {$ENDIF}

Procedure DoBleep (Freq : Word; MSecs : Integer);
Begin
If MSecs<-1 Then MSecs:=0;
{$IFDEF WIN32} If SysWinNT Then Windows.Beep (Freq, MSecs) Else {$ENDIF}
HardBleep (Freq, MSecs);
End;

Procedure ShutUp;
Begin
{$IFDEF WIN32} If SysWinNT Then Windows.Beep (1, 0) Else {$ENDIF}
AsmShutUp;
End;

{$IFDEF WIN32}

Procedure InitSysType;
Var
VersionInfo : TOSVersionInfo;
Begin
VersionInfo.dwOSVersionInfoSize:=SizeOf (VersionInfo);
GetVersionEx (VersionInfo);
SysWinNt:=VersionInfo.dwPlatformID=VER_PLATFORM_WIN32_NT;
End;

Initialization
InitSysType;

{$ENDIF}

End.

这是从别处download下来,还有demo,试试觉得应该可以满足你的
要求.只提供主要部分,如果要全部,也可以.

来自uddf,试了一下,吵得要死


unit Unit1;

interface

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

type
TForm1 = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;
procedure Sound(Freq : Word);
procedure NoSound;
procedure SetPort(address, Value:Word);
function GetPort(address:word):word;

implementation

{$R *.DFM}

procedure Sound(Freq : Word);
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 NoSound;
var
Value: Word;
begin
Value := GetPort($61) and $FC;
SetPort($61, Value);
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;

function GetPort(address:word):word;
var
bValue: byte;
begin
asm
mov dx, address
in al, dx
mov bValue, al
end;
GetPort := bValue;
end;


procedure TForm1.Button1Click(Sender: TObject);
begin
sound(1234);
sleep(500);
nosound;
end;

end.

各位大虾真的在nt下调通了吗?者好像是一个空间的原码,我在nt下执行老是出错.
各位怎么调通的?

to: yifeng
呵呵，你贴的东东和俺贴的怎么一样呢？ 不过我是在BORLAND NEWS里记下来的


to : li zhang yi
我在NT 下执行也是出错， 在95下没问题

诸位老大，看清题目，我明明要在 NT 下的。可是...
这几天我实在心情不好。

to Cj:
最简单的办法，我试过了，呵呵
windows.beep(110,500); //110是频率，500是500毫秒 这是发出 "陡"
windows.beep(220,500); //大概是 "瑞"

没注意DELPHI里就带着 :-D

快乐要自己去找 （这两天俺也是心情不好，所以到这里来寻寻开心 )

最长多久？好象有范围，是多少？
我也是

>快乐要自己去找 （这两天俺也是心情不好，所以到这里来寻寻开心 )
~~~~~~~~~~~~~~~~~原来拿俺寻开心
来着
下面是来自MSDN的关于Beep的说明:
BOOL Beep(
DWORD dwFreq, // sound frequency, in hertz
DWORD dwDuration // sound duration, in milliseconds
);

Parameters
dwFreq
Windows NT: Specifies the frequency, in hertz, of the sound. This parameter must be in the range 37 through 32,767 (0x25 through 0x7FFF).
dwDuration
Windows NT: Specifies the duration, in milliseconds, of the sound.
这个函数是异步的，没说有时间限制。

原来是NT下的....
呵呵,没看清题目

我的BEEP怎么没参数？？？

我用D3,D4都可以
windows.beep
难道CJ用的是D1吗？ xixi

sorry