DBR Delphi-Ecke

// Im Zeitalter der Soundkarten braucht man den internen Lautsprecher kaum
// noch. Wenn aber doch, dann schlage ich den folgenden Code vor.
// Die Prozedur Ton wird mit zwei Parametern aufgerufen:
// 1. Frequenz (in Hertz)
// 2. Dauer (in Millisekunden)
// Gibt man für Dauer 0 an, wird ein Dauerton erzeugt. Gibt man für
// Frequenz 0 an, wird die Tonausgabe angehalten.
// Durch Aufruf der Prozedur PiepserAbschalten wird die Ausgabe weiterer Töne
// verhindert. Durch PiepserEinschalten wird die Ausgabe von Tönen wieder erlaubt.

// Getestet mit D4 unter Win98

{ für NT findet man in der Unit Windows:
function Beep(dwFreq, dwDuration: DWORD): BOOL; stdcall; }

const ohnepieps: boolean = false; 
 
procedure Ton(freq: word; dauer: longword); 
var zeit: longword; 
  procedure aus; assembler; 
  asm 
    mov  al, 182 
    out $43, al 
    in   al, $61 
    and  al, 3 
    out $61, al 
  end; 
begin 
  if ohnepieps then exit; 
  if (freq = 0) then aus else begin 
    freq := 1193180 div freq; 
    asm 
      mov  al, 182 
      out $43, al 
      in   al, $61 
      or   al, 3 
      out $61, al 
      mov  ax, freq 
      out $42, al 
      mov  al, ah 
      out $42, al 
    end; 
    if dauer = 0 then exit; 
    zeit := gettickcount + dauer; 
    repeat 
      application.processmessages; 
    until gettickcount >= zeit; 
    aus; 
  end; 
end; 
 
procedure PiepserAbschalten; 
begin 
  ton(0, 0); 
  ohnepieps := true; 
end; 
 
procedure PiepserEinschalten; 
begin 
  ohnepieps := false; 
end; 
 
 
//-------- Beispielaufrufe ------------ 
 
// Dauerton ausgeben 
procedure TForm1.Button4Click(Sender: TObject); 
begin 
  ton(700, 0); 
end; 
 
// Dauerton abbrechen 
procedure TForm1.Button2Click(Sender: TObject); 
begin 
  ton(0, 0); 
end; 
 
// Kurzton ausgeben 
procedure TForm1.Button3Click(Sender: TObject); 
begin 
  ton(440, 125); 
end; 
 
// Tonfolge ausgeben 
procedure TForm1.Button5Click(Sender: TObject); 
var x: integer; 
begin 
  for x := 1 to 10 do 
    ton(x * 177, 100 - x * 2); 
end; 
 
// Tonausgabe erzwingen 
procedure TForm1.Button8Click(Sender: TObject); 
begin 
  PiepserEinschalten; 
  ton(1000, 500); 
end; 
 
// bei Programmende nicht vergessen abzuschalten, da sonst 
// die Töne ohne Programm trotzdem weiter ausgegeben werden. 
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction); 
begin 
  PiepserAbschalten; 
end;