Befehl immer wieder ausführen ohne CPU belastung

[NicoleWagner]

Das ist ein ganz alter Sound-Code. Weiss nicht, was Du etwas davon gebrauchen kannst.
Warnungen wirst Du sehen. Funktionieren sollte er aber schon.

Beachte bitte, dass "Beep" in mehreren Units vorhanden ist.
Es gibt einen von system, utils, windows oder so.

Delphi-Quellcode:

unit Sound_ausgabe;
Interface
uses windows, sysutils;
Procedure Tonausgabe;
procedure Sound(aFreq, aDelay: Integer) ;
procedure NoSound;

//******************************************************************************
implementation
Procedure Tonausgabe;
begin
 { 
aufrufen mit:
  Tonausgabe; // Ausgabe auf dem Systemlautsprecher, also ohne Boxen



 Sound(500, 100) ; //erst Ton, dann Dauer
   Sound(590, 90) ;
   Sound(710, 160) ;  // klingt falsch
   Sound(440, 100) ; //erst Ton, dann Dauer
   Sound(880, 90) ;
   Sound(260, 160) ;   // klingt wie ein nervendes Spiel
   
   Sound(260, 90);
   Sound(440, 100);
   Sound(880, 100); }

   Sound(440,200);
   NoSound;
end;
{
G: 440
a, eine Oktave tiefer (leere A-Saite) hat genau die halbe Schwingungszahl, nämlich 220 Hz
(Oktaven bilden also immer exakte Vielfache oder glatte Quotienten einer Grundzahl.
Die Oktaven zum Ton a (= 440 Hz) liegen nach unten bei 220, 110, 65, 32,5
und 16,25 Hz, nach oben bei 880, 1760 Hz usw.)

Frequenz: 136,10 Hertz (Ton: CIS)
Frequenz: 147,85  Hertz (Ton: D)
Frequenz: 172,06 Hertz (Ton: F)  22.12
Frequenz: 194,18 Hertz (Ton: G)
Frequenz: 210,42 Hertz (Ton: GIS) 16.24
Frequenz: 221,23 Hertz (Ton: A)
Frequenz: 194,18 Hertz (Ton: Ais) ???
Frequenz: 241,56 Hertz (Ton: H)
 
}


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 Sound(aFreq, aDelay: Integer) ;
////////////////////////////////////////////////////////////////////////////////
   procedure DoSound(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 Delay(MSecs: Integer);// habe vor GetTick Count 2x Abs() eingefügt
   var
     FirstTickCount: Integer; //vorher: LongInt; sollte ident sein
   begin
     FirstTickCount := Abs(GetTickCount);
     repeat
       Sleep(1) ;
       //or use Application.ProcessMessages instead of Sleep
     until ((Abs(GetTickCount) - FirstTickCount) >= Longint(MSecs)) ;
   end;
//GetTickCount aus Kernel:
// Retrieves the number of milliseconds that have elapsed since the system was started
////////////////////////////////////////////////////////////////////////////////
begin
   if Win32Platform = VER_PLATFORM_WIN32_NT then
   begin
     Windows.Beep(aFreq, aDelay) ;
   end
   else
   begin
     DoSound(aFreq) ;
     Delay(aDelay) ;
   end;
end;
//******************************************************************************
procedure NoSound;
var
   Value: Word;
begin
   if not (Win32Platform = VER_PLATFORM_WIN32_NT) then
   begin
     Value := GetPort($61) and $FC;
     SetPort($61, Value) ;
   end;
end;
//******************************************************************************
end.