|
：sunstone 时间：00-9-3 7:51:42 ID:325632 送你一个控件 unit PCSpk; {* Program : PCSpk.Pas Purpose : TPCSpeaker Component Author Version Last Changed Comments ------ ------- ------------ -------- Song Weng Sam 1.01 Aug. 28, 96 Initial Release (Version set to 1.01 to match the 16bit version which is currently 1.01 too.) *} interface uses Classes, WinProcs, Forms; type TPCSpeaker = class(TComponent) private { Private declarations } procedure NoSound; procedure Sound(Freq: Word); procedure SetPort(address, value: Word); function GetPort(address: Word): Word; protected { Protected declarations } public { Public declarations } procedure Delay(MSecs: Integer); procedure Play(Freq: Word; MSecs: Integer); procedure Stop; published { Published declarations } end; procedure Register; implementation procedure TPCSpeaker.NoSound; var wValue: Word; begin wValue := GetPort($61); wValue := wValue and $FC; SetPort($61, wValue); end; procedure TPCSpeaker.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 TPCSpeaker.Delay(MSecs: Integer); var FirstTickCount : LongInt; begin FirstTickCount:=GetTickCount; repeat Application.ProcessMessages; {allowing access to other controls, etc.} until ((GetTickCount-FirstTickCount) >= LongInt(MSecs)); end; procedure TPCSpeaker.Play(Freq: Word; MSecs: Integer); begin Sound(Freq); Delay(MSecs); NoSound; end; procedure TPCSpeaker.Stop; begin NoSound; end; procedure TPCSpeaker.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 TPCSpeaker.GetPort(address: Word): Word; var bValue: Byte; begin asm mov DX, address in AL, DX mov bValue, AL end; result := bValue; end; procedure Register; begin RegisterComponents('Sun', [TPCSpeaker]); end; end. -------------------------------------------------------------------------------- 来自：浦欣 时间：00-9-4 1:29:47 ID:326342 sunstone的这个控件实际上和原来提问中的那段程序一样，但我还想要得是一些声音例子，就象 “电子日记本”的“备忘录”中，有一些做好的声音可选！ 或者给出每个调所对应的频率 来自：terry_lzs 时间：00-10-24 10:48:33 ID:374463 用汇编吧 unit Unit1; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls; type Tpcspeaker = class(TForm) Button1: TButton; Button2: TButton; procedure Button1Click(Sender: TObject); procedure Button2Click(Sender: TObject); private procedure NoSound; procedure Sound(Freq: Word); procedure SetPort(address, value: Word); function GetPort(address: Word): Word; { Private declarations } public procedure Delay(MSecs: Integer); procedure Play(Freq: Word; MSecs: Integer); { Public declarations } end; var pcspeaker: Tpcspeaker; implementation {$R *.DFM} procedure TPCSpeaker.NoSound; var wValue: Word; begin wValue := GetPort($61); wValue := wValue and $FC; SetPort($61, wValue); end; procedure TPCSpeaker.Sound(Freq: Word); var B: Word; begin if Freq > 18 then begin Freq := Word(1193181 div LongInt(Freq)); B := GetPort($61); 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 TPCSpeaker.Delay(MSecs: Integer); var FirstTickCount : LongInt; begin FirstTickCount:=GetTickCount; repeat Application.ProcessMessages; {allowing access to other controls, etc.} until ((GetTickCount-FirstTickCount) >= LongInt(MSecs)); end; procedure TPCSpeaker.Play(Freq: Word; MSecs: Integer); begin Sound(Freq); Delay(MSecs); //NoSound; end; procedure TPCSpeaker.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 TPCSpeaker.GetPort(address: Word): Word; var bValue: Byte; begin asm mov DX, address in AL, DX mov bValue, AL end; result := bValue; end; procedure Tpcspeaker.Button1Click(Sender: TObject); begin play(1800,100);//由这两个参数控制音调 end; procedure Tpcspeaker.Button2Click(Sender: TObject); begin NoSound; end; end. 来自：whb_li 时间：00-10-26 0:17:21 ID:376428 to terry_lzs: 打扰，我用你的代码调试了一下，发现 asm mov DX, address in AL, DX /////这一行出错 mov bValue, AL end; -------------------------------------------------------------------------------- 来自：terry_lzs 时间：00-10-26 8:27:07 ID:376539 to whb_li:我在我的电脑上用delphi 4和delphi 5都试过了，没有问题。 如果你是把网页上的直接拷贝到unit上请注意删除一些不可见的字符。 我以前有遇到这种问题的。 -------------------------------------------------------------------------------- 来自：pino 时间：00-11-21 9:49:23 ID:399668 在nt下不能直接对端口操作，可以用api messagebeep 而在win9x下就不能用api，可以在代码里面根据系统选择实现方式 来自：xjktthq 时间：00-11-21 9:57:09 ID:399678 for i:=9 to 20 do windows.beep(i*130,20); -------------------------------------------------------------------------------- 来自：cat.yy 时间：01-1-31 23:25:07 ID:445935 呀呀 鞋都跑丢了 不知能否帮上忙 (用API 如果有声卡 好像有点麻烦) *------------------------------- DLL 的 dpr 代码 -------------- library SpeakSound; //uses // SysUtils, // Classes, procedure pcSound(dFreq:Double;wLong:Word);export; var wFreq:word; begin wFreq := round(1192576/dFreq); asm push ax push bx push cx push dx push di mov al,0B6H out 43H,al mov dx,12H mov ax,wFreq out 42H,al mov al,ah out 42H,al in al,61H mov ah,al or al,3 out 61H,al @wait1: mov cx,wLong @delay: dec cx jnz @delay dec bx jnz @wait1 mov al,0B6H out 43H,al mov al,ah out 61H,al pop di pop dx pop cx pop bx pop ax end; end; exports pcSound; begin end. * ------------------------------ 调用的例子 ------------------ 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; implementation {$R *.DFM} procedure TForm1.Button1Click(Sender: TObject); var DLLName:string; Buffer:array[0..127] of Char; LIB:THandle; pcSound:procedure(dFreq:Double;wLong:Word); begin DLLName := 'SpeakSound.dll'; StrPCopy(Buffer,DLLName); Lib := LoadLibrary(Buffer); if not(Lib=0) then try pcSound := GetProcAddress(Lib,'pcSound'); pcsound(440.0,1000); Finally FreeLibrary(Lib); end else Showmessage('failed'); end; end. { 261.7 c 293.7 d 329.6 e 349.2 f 392.0 g 440.0 a 493.9 b } -------------------------------------------------------------------------------- 来自：悲酥清风 时间：01-2-6 16:23:18 ID:450522 AHM2000 Freeware 中有个PcSpeaker控件，带源码的，源码在AHM2000的主叶上有！ 来自：Iknow 时间：01-2-6 17:36:31 ID:450601 ^_^ 连cdefgab都出来了. 音乐功底不错嘛. c=1, d=2, ... ^_^ 其实如果是在Windows下, 为什么不尝试用系统中的声卡设备(如果有的话)? DOS下如果用Borland Pascal的话, 可以用sound(frequency);delay(duration);nosound; 组合来发声, 效果还可以的.
| 
中搜索 