Форум программистов [Powered by Invision Power Board]

Версия для печати темы
Нажмите сюда для просмотра этой темы в оригинальном формате

Форум программистов > Delphi: WinAPI и системное программирование > Работа системного динамика

Автор: Albinos_x 27.5.2004, 21:11

Помогите, не могу заставить пищать системный динамик!

Привожу код

Код

unit Unit1;

interface
uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, Buttons, StdCtrls, Spin, ExtCtrls,unit2;
type
  TForm1 = class(TForm)
    SpeedButton1: TSpeedButton;
    SpinEdit1: TSpinEdit;
    SpinEdit2: TSpinEdit;
    Timer1: TTimer;
    Label1: TLabel;
    Label2: TLabel;
    SpeedButton2: TSpeedButton;
    procedure SpeedButton1Click(Sender: TObject);
    procedure Timer1Timer(Sender: TObject);
    procedure SpeedButton2Click(Sender: TObject);
    procedure FormCreate(Sender: TObject); 
  private
    { Private declarations }
  public
    { Public declarations }
  end;
var
  Form1: TForm1;
implementation
{$R *.dfm}

procedure TForm1.SpeedButton1Click(Sender: TObject);
var fr:word;
begin
Timer1.Interval:=SpinEdit2.Value;
fr:=SpinEdit1.Value;
sound1(fr);
Timer1.Enabled:=true;
end;

procedure TForm1.Timer1Timer(Sender: TObject);
begin
nsound1;
Timer1.Enabled:=false;
end;

procedure TForm1.SpeedButton2Click(Sender: TObject);
begin
Application.Terminate;
end;

procedure TForm1.FormCreate(Sender: TObject);
var HToken:THandle;
    Luid:TLargeInteger;
    Tkp:TTokenPrivileges;
    ReturnLength:Cardinal;
begin
if OpenProcessToken(GetCurrentProcess,TOKEN_ADJUST_PRIVILEGES,HToken) THEN
   begin
   LookupPrivilegeValue(nil,'SeShutdownPrivilege',Luid);
   Tkp.Privileges[0].Luid:=Luid;
   Tkp.PrivilegeCount:=1;
   Tkp.Privileges[0].Attributes:=SE_PRIVILEGE_ENABLED;
   if AdjustTokenPrivileges(HToken,false,Tkp,0,nil,ReturnLength) then
      begin
      MessageDlg('Получены привилегии',mtInformation,[mbOk],0);
      end
      else
      MessageDlg('Привилегии не получены',mtInformation,[mbOk],0);
   end
   else
   MessageDlg('Получение привилегий не возможно',mtInformation,[mbOk],0);
end;
end.

unit Unit2;

interface

    procedure sound1(var f:word);
    procedure nsound1;
    
implementation

function getport1(addres:word):word;
var b:byte;
begin
 asm
  mov dx,addres
  in al,dx
  mov b,al
  end;
  getport1:=b;
end;

function setport1(addres,v:word):word;
var b:byte;
begin
b:=trunc(v and 255);
 asm
  mov dx,addres
  mov al,b
  out dx,al
  end;
end;

procedure sound1(var f:word);
var z,sss:byte;
begin
if f>18 then
   begin
   f:=word(1193181 div longint(f));
   z:=getport1($61);
   if (z and 3)=0 then
      begin
      setport1($61,z);
      setport1($43,$b6);
      end;
   setport1($42,f);
   setport1($42,f shr 8);
   end;
end;

procedure nsound1;
var v:word;
begin
v:=getport1($61) and $fc;
  setport1($61,v)
end;

end.

Если кто знает напишите в чём ошибка, и если возможно то под ХР тоже.

Автор: p0s0l 27.5.2004, 21:50

Есть функция Beep, но под 9x она издает монотонный звук, т.е. частота не меняется...
Вот универсальный код:

Код


Procedure  BeepEx(Freq:  Word;  Duration:  Integer);
 var  
     Ver:  TOsVersionInfo;
 begin
     Ver.dwOSVersionInfoSize  :=  SizeOf(Ver);
     GetVersionEx(Ver);
     if  Ver.dwPlatformId  =  VER_PLATFORM_WIN32_NT  then  
         Windows.Beep(Freq,  Duration)  
     else  begin
         asm
             movzx  ecx,  Freq
             mov  eax,  1193180            //  тактовая  частота
             sub  edx,  edx
             div  ecx                              //  преобразование  частоты  в  делитель
             mov  ecx,  eax
             mov  al,0b6H
             out  43H,al                        //  управляющие  слово
             mov  al,cl
             out  42h,al                        //  младший  байт  делителя
             mov  al,ch
             out  42h,al                        //  старший  байт  делителя
             in    al,61H
             or    al,03H
             out  61H,al                        //  включить  звук
         end;
         sleep(Duration);                //  пауза  на  время  звучани
         asm
             in    al,61H
             and  al,0fcH
             out  61H,al                        //  выключить  звук  по  окончанию  Duration
         end;
     end;
 end;

Автор: Albinos_x 27.5.2004, 22:15

Спасибо за ответ, но
функция Beep, согласно описания, не заставит пищать системный динамик если установлена звуковая карта (я проверял).
Мне нужно, чтобы он пищал независимо от этого, длительностью и частотой заданной пользователем.
К тому же Beep( Freg, Duration) почему-то, у меня отказываеся компилироваться!!!

Автор: p0s0l 28.5.2004, 00:07

Ну, у меня XP, звуковая есть - и всё пищит нормально...
И компилируется нормально - прямо отсюда вставил в проект...
Какая ошибка выдаётся ?

И надо писать не Beep(Freq, Duration), а Windows.Beep(Freq, Duration), т.к. процедура Beep есть и в Windows.pas, и в SysUtils.pas...

Пример вызова приведенной выше функции:
BeepEx(555, 100);

Автор: Albinos_x 28.5.2004, 00:57

Спасибо!!!

Теперь всё работает.