[Webinar] Streamline your web hosting managementRegister Today

x
  • Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 456
  • Last Modified:

Controlling the PC Speaker from Delphi 3

In the good old days of dos 2.1. One could give a command "sound" and the PC-speaker would start making a noise untill it is stopped. Now things are different. We tell windows 95 we want a beep, it goes and determines the sound card and the type of sound the user configured and does the rest for you.

Unfortunately, the PC-speaker beep, ie, there is no sound card, is very soft and short. When one puts this in a heavy duty box, behind a panel, it cannot be heard. This is my problem.

HOW DO I SPECIFY THE FREQUENCY AND DURATION OF A PC-SPEAKER BEEP IN WIN95

I tried messagebeep, these all amounts to exactly the same sound. I tried two different Beep procedures, the one is without parameters and gives the same beep. The other beep procedure takes two parameters that the help says is used by Win NT, but ignored by Win95. Yes, it gives me the beep that is exactly the same as all the others.

There is one thing that starts approaching an answer, that is calling something like ten of these Beep's after the other, but it is not what one can discribe as a smooth solution. (And wastes time in an application that is already time criticcal.)

Any advice????
0
bra033098
Asked:
bra033098
1 Solution
 
MatveyCommented:
There's a driver for PC-Speaker in windows - similar to SB driver. -Don't ask me if it works, but I might find it. So if you think it can help - post your email.
0
 
ZifNabCommented:
Hi bra, a while ago a gave this answer. Does it suits for you?

    Found them some time ago on the net,

    Making PC Speaker Sound


    Below are the procedures Sound, NoSound, and Delay. They are called in
    the same way that Turbo Pascal's Sound, NoSound, and Delay procedures are
    called. For example, to produce a 600 Hz tone for 200 milliseconds, you
    would call the procedures as follows:

       Sound(600);
       Delay(200);
       NoSound;

    procedure TForm1.NoSound;
    begin
       Port[$61] := Port[$61] and $FC;
    end;


    procedure TForm1.Sound(Freq : Word);
    var
       B : Byte;
    begin
       if Freq > 18 then
          begin
             Freq := Word(1193181 div LongInt(Freq));

             B := Port[$61];

             if (B and 3) = 0 then
                begin
                   Port[$61] := B or 3;
                   Port[$43] := $B6;
                end;

             Port[$42] := Byte(Freq);
             Port[$42] := Byte(Freq shr 8);
          end;
    end;


    procedure TForm1.Delay(MSecs : Integer);
    var
       FirstTickCount : LongInt;
    begin
       FirstTickCount:=GetTickCount;
       repeat
          Application.ProcessMessages; {allowing access to other controls,
                                        etc.}
       until ((GetTickCount-FirstTickCount) >= LongInt(MSecs));
    end;

    Author: Thomas Foster

    Regards, Zif.





0
[Webinar] Improve your customer journey

A positive customer journey is important in attracting and retaining business. To improve this experience, you can use Google Maps APIs to increase checkout conversions, boost user engagement, and optimize order fulfillment. Learn how in this webinar presented by Dito.

 
MatveyCommented:
Cool Zif! ;-)

I'll check it out too
0
 
ZifNabCommented:
My pleasure Matvey ;-)
0
 
MatveyCommented:
Hmmm Zif,  "  Undeclared identifier 'Port'  "

I think something needs to be added to the USES...
0
 
jannesCommented:
Try this unit.
I always use it in my educational programs...
In this way you can play all simple songs.

Met vriendelijke groeten,

Jannes

Email : stevens@okido.demon.nl
URL   : www.okido.demon.nl



unit Umusic;

interface

uses
  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  FileCtrl, IniFiles, Forms, Dialogs;

type
  TFMuziek = class(TForm)
    procedure FormActivate(Sender: TObject);
    procedure Sendnote;
    procedure Speel;
    procedure Getnum;
  private
    ModuleName, pchartemp  : array[0..255] of char;
    kk, dt, nm, st, pk, nr: LongInt;
    SearchRec: TSearchRec;
    ApplIni: string[60];
    Code, status, i: Integer;
    ini,strnm,nn,schijf: string[8];
    yy,mm,dag,yy2,mm2,dag2,uur,min,sec,msec:word;
  public
    music, dots, octave, voice:integer;
    data, reeks: string[128];
    newnote, newaccent:boolean;
    playlength, notelength, tempnum, pitch, tchars, tempo, lengte, charoff :integer;
    letter: string[1];
    numbers: string[10];
  end;

var
  FMusic: TFMusic;

implementation

{$R *.DFM}

procedure TFMusic.FormActivate(Sender: TObject);
begin
   reeks:='T240O2E8G4A8MLB8.>C16.MN<B8A4F#8MLD8.E16.MNF#8G4E8MLE8.D#16.MNE8F#4.<B4>';
   Speel;
end;

procedure TFMusic.Speel;
begin
    SetVoiceQueueSize(1,192);
    TChars:=Length(reeks);
    Tempo:=120;
    music := 0;
    Octave := 3;
    Lengte := 4;
    NewNote := False;
    NewAccent := True;
    CharOff := 1;
    repeat begin
      letter:=copy(reeks,charoff,1);
      if ((letter>='A') and (letter<='G')) or (letter='P')
      then begin
        sendnote;
        if letter='P' then pitch:=0;
        if letter='C' then pitch:=1;
        if letter='D' then pitch:=3;
        if letter='E' then pitch:=5;
        if letter='F' then pitch:=6;
        if letter='G' then pitch:=8;
        if letter='A' then pitch:=10;
        if letter='B' then pitch:=12;
        newnote:=true;
      end
      else if (letter>='1') and (letter<='9') then begin
        getnum;
        notelength:=tempnum;
      end
      else if letter='>' then begin
        sendnote;
        inc(octave);
      end
      else if letter='<' then begin
        sendnote;
        dec(octave);
      end
      else if (letter='+') or (letter='#') then inc(pitch)
      else if letter='-' then dec(pitch)
      else if letter='.' then inc(dots)
      else if letter='M' then begin
        sendnote;
        inc(charoff);
        letter:=copy(reeks,charoff,1);
        if letter='N' then music:=0;
        if letter='S' then music:=2;
        if letter='L' then music:=1;
        newaccent:=true;
      end
      else if letter='N' then begin
        sendnote;
        inc(charoff);
        getnum;
        pitch:=tempnum;
        newnote:=true;
        sendnote;
      end
      else if letter='O' then begin
        sendnote;
        inc(charoff);
        getnum;
        octave:=tempnum;
      end
      else if letter='T' then begin
        sendnote;
        inc(charoff);
        getnum;
        tempo:=tempnum;
        newaccent:=true;
      end
      else if letter='L' then begin
        sendnote;
        inc(charoff);
        getnum;
        lengte:=tempnum;
      end;
      inc(charoff);
    end until charoff>tchars;
    sendnote;
    startsound;
end;

procedure TFMusic.Sendnote;
begin
    If NewAccent Then SetVoiceAccent(1, Tempo, 1, music, 0);
    If NewNote Then begin
      If Pitch > 0 Then Pitch := (Pitch + (Octave * 12)) - 1;
      If NoteLength > 0 Then begin
          PlayLength := NoteLength;
          NoteLength := 0;
        end
      Else PlayLength := Lengte;
      SetVoiceNote (1, Pitch, PlayLength, Dots);
      Dots := 0
    End;
    NewNote := False;
    NewAccent := False;
end;

procedure TFMusic.getnum;
var
  TestChar: string[1];
begin
  numbers := '0123456789';
  TempNum := strtoint(copy(reeks, CharOff, 1));
  If CharOff < TChars Then begin
    TestChar := copy(reeks, CharOff + 1, 1);
    If (TestChar >= '0') and (testchar <= '9')  Then begin
      TempNum := TempNum * 10 + strtoint(TestChar);
      inc(CharOff);
    end
    Else exit;
  End;
  If CharOff < TChars Then begin
    TestChar := copy(reeks, CharOff + 1, 1);
    If (TestChar >= '0') and (testchar <= '9')  Then begin
      TempNum := TempNum * 10 + strtoint(TestChar);
      inc(CharOff);
    End;
  End;
end;

end.

0
 
MatveyCommented:
Hi Jannes, the same here as with ZifNabs code;

"  Undeclared identifier 'SetVoiceQueueSize'  "
"  Undeclared identifier 'startsound'  "
"  Undeclared identifier 'SetVoiceAccent'  "
"  Undeclared identifier 'SetVoiceNote'  "

I think you missed some unit or something...
0
 
bra033098Author Commented:
Matvey

I found the driver under
http://www.biozentrum.uni-wuerzburg.de/sounds/win95installation.html

Will try it out and let know if it works

bra
0
 
MatveyCommented:
Great!

bra, have you tried any of the sugestions above? Did they work on your machine?
0
 
kjtengCommented:
You can use the API in mmsystem to send a wav file to pc speaker.
For example
sndPlaySound( 'SystemDefault', snd_NoDefault)
sndPlaySound( 'file.wav', snd_NoDefault) etc

For more details please see:
http://www.experts-exchange.com/topics/comp/lang/delphi/Q.10056799

kjteng
0
 
MatveyCommented:
I think the TMediaPlayer component will play it OK too - the windows sound recorder should play it well.
0
 
ZifNabCommented:
Ok, what does this ?

procedure Sound(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 NoSound;
var
  Value: Word;
begin
    Value := GetPort($61) and $FC;
    SetPort($61, Value);
end;

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;

Zif.

0
 
MatveyCommented:
Yeah!!! It works! Very cool Tom!
0
 
ZifNabCommented:
Hello bra,

everything ok?

Zif.
0

Featured Post

Free Tool: SSL Checker

Scans your site and returns information about your SSL implementation and certificate. Helpful for debugging and validating your SSL configuration.

One of a set of tools we are providing to everyone as a way of saying thank you for being a part of the community.

Tackle projects and never again get stuck behind a technical roadblock.
Join Now