Funcao - usando o speaker para tocar beeps

Tocando BEEPs no SPEAKER:

Para Windows 9x e Windows NT (2000)

================================================

// Inicio PlaySound

// Rotina usada pela PlaySound

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;

// Rotina usada pela PlaySound

function GetPort(address: Word): Word;

var

  bValue: Byte;

begin

  asm

    mov DX, address

    in  AL, DX

    mov bValue, AL

  end;

  result := bValue;

end;

// Interrompe um som emitido pela PlaySound

procedure NoSound;

var

  wValue: Word;

begin

  wValue := GetPort($61);

  wValue := wValue and $FC;

  SetPort($61, wValue);

end;

function WindowsNT: Boolean;

var

  verInfo: TOsVersionInfo;

begin

  verInfo.dwOSVersionInfoSize := SizeOf(TOSVersionInfo);

  if GetVersionEx(verInfo) then

    Result := verInfo.dwPlatformId = VER_PLATFORM_WIN32_NT

  else

    Result := False;

end;

// Toca um som no speaker

procedure PlaySound(Freq: Word; const MSecs: Cardinal);

var

  B, wValue : Word;

  F         : Cardinal;

begin

  if WindowsNT then

  begin

    Windows.Beep(Freq,MSecs);

    Exit;

  end;

  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;

  F := GetTickCount;

  repeat

    Application.ProcessMessages;

  until (GetTickCount-F >= MSecs);

  wValue := mlGetPort($61);

  wValue := wValue and $FC;

  SetPort($61, wValue);

end;

procedure Bip;

begin

  PlaySound(2000,100);

end;

procedure SomOK;

begin

  PlaySound(2000,85);

  Delay(50);

  PlaySound(2000,85);

end;

// Final PlaySound