Tipy a triky v Delphi, díl 19.

Systémové pípnutí (beep) slouží k upozornění systému či aplikací na různé události. Pokud budete chtít toto "pípání" zakázat, slouží k tomu následující funkce.

procedure TForm1.Button18Click(Sender: TObject);
begin
  SystemParametersInfo(SPI_SETBEEP,0,NIL,SPIF_SENDWININICHANGE);
end;

A touto funkcí vše opět vrátíme do původního stavu.

procedure TForm1.Button19Click(Sender: TObject);
begin
  SystemParametersInfo(SPI_SETBEEP,1,NIL,SPIF_SENDWININICHANGE);
end;

Když už jsme u toho "pípání", naučíme se tvořit zvuky přes PC speaker. Myslíte, že už je to dnes v době zvukových karet zastaralé a zbytečné? Možná, ale pro jednoduché ozvučení vaší aplikace se to může hodit, protože PC speaker má jednu nespornou výhodu oproti zvukové kartě. Je totiž v počítači vždy (tedy téměř) což se o zvukové kartě říci nedá.

Žádnou extra hudbu sice ze speakeru nevyčarujete, ale pro různé zvuky, které mají uživatele na něco upozornit či varovat to plně postačí.

Zdrojový kód je poněkud delší než obvykle, protože příklad obsahuje nejen samotnou proceduru na vytvoření zvuku dané frekvence, ale také pauzu (delay), o které sice už v našem seriálu byla řeč, ale pro úplnost příkladu je zde funkce uvedena znovu. A samozřejmě je součástí příkladu též funkce na vypnutí zvuku (nosound), bez níž by speaker "pískal" stále a nezbývalo by vám, než počítač restartovat.

Většina z vás možná bude znát použití těchto funkcí z klasického Turbo (Borland) Pascalu. V naší je ukázce je menší změna v tom, že se Delay nepoužívá zvlášť, ale je to interní součást procedury Sound a pauza je tím pádem jejím druhým parametrem.

Jako ukázka použití je na samém závěru opět obsluha události tlačítka, která udělá jednoduché trojité pípnutí.

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);
  var
  FirstTickCount : LongInt;
  begin
    FirstTickCount:=GetTickCount;
  repeat
    SleepEX(1, false);     
  until ((GetTickCount-FirstTickCount) >= LongInt(MSecs));
  end;

begin
  DoSound(aFreq);
  Delay(aDelay);
end;

procedure NoSound;
var
  Value: Word;
begin
    Value := GetPort($61) and $FC;
    SetPort($61, Value);
end;


procedure TForm1.Button1Click(Sender: TObject);
begin
  Sound(500,100);
  Sound(700,100);
  Sound(900,100);
  NoSound;
end;

Pro úplnost dodávám, že příklad by měl fungovat pod Windows 9x.

A teď zase z jiného soudku, ukážeme si, jak zjistit sériové číslo pevného disku (přesněji konkrétní partition) či disku CD. To je informace, která se dá použít na různé účely, ať informační či bezpečnostní. Parametrem funkce je pouze písmeno požadovaného disku (dvojtečka s lomítkem se přidá sama). Jako menší "bonus" funkce vrací též jmenovku (label) disku. Zde je tedy kód funkce včetně použití:

function GetHardDiskSerial(const DriveLetter:  char):  string;
var
  NotUsed          :  dWord;
  VolumeFlags      :  dWord;
  VolumeInfo        :  array[0..MAX_PATH] of char;
  VolumeSerialNumber:  dWord;
begin
GetVolumeInformation(PChar(DriveLetter + `:\`), VolumeInfo, SizeOf(VolumeInfo), @VolumeSerialNumber, NotUsed, VolumeFlags, nil, 0);
result := Format(`Label = %s  VolSer = %8.8X`, [VolumeInfo, VolumeSerialNumber]);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
ShowMessage(GetHardDiskSerial(`c`));
end;

Na závěr tu mám opět jeden vizuální trik. Přidáním následujícího kódu dosáhneme toho, že ke zvoleným komponentám bude přidán stín požadované tloušťky a barvy. Je nutné poznamenat několik drobností. Jednak si musíte dobře rozmyslet, pro které komponenty tento efekt použijete, protože ne vždy to vypadá dobře. Zároveň je třeba zvolit decentní tloušťku i barvu, ale to vám snad nemusím připomínat. Vše opět záleží na celkovém rázu vaší aplikace. A poslední věc, na kterou je třeba upozornit, je nutnost ohlídat si překreslování, protože jinak se například po obnovení aplikace z minimalizovaného stavu všechny stíny ztratí.

V naší ukázce je pro názornost opatřena stínem každá komponenta, ale samozřejmě máte v rámci parametrů funkce možnost si vybrat přímo konkrétní komponentu. Samotný kód je vhodné umístit do události OnPaint daného formuláře, čímž si zajistíte automatické překreslování.

Parametry funkce jsou velice jednoduché - formulář, komponenta pro kterou je stín použit, tloušťka stínu a konečně barva stínu.

A nyní již naše ukázka:

Procedure Stin(f: TForm; c: TControl; Width: Integer; Color: TColor);
var
  rect: TRect;
  old: TColor;
Begin
  rect := c.boundsrect;
  rect.Left := rect.Left + width;
  rect.Top := rect.Top + width;
  rect.Right := rect.Right + width;
  rect.Bottom := rect.Bottom + width;
  old := f.canvas.brush.color;
  f.canvas.brush.Color := color;
  f.canvas.fillrect(rect);
  f.canvas.brush.Color := old;
end;

procedure TForm1.FormPaint(Sender: TObject);
var
  i: Integer;
begin
for i:=0 to Self.ControlCount-1 do Stin(self,Self.Controls[i],3,clblack);
end;