Tipy a triky v Delphi, díl 19.

Dneska tu máme opět všehochuť různých tipů. Ukážeme si, jak pískat přes PC speaker, jak zjistit sériové číslo disku, a na závěr si ukážeme, jak přidat stíny k vizuálním komponentám.
Povolení a zakázání systémového pípnutí

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;

Tvorba zvuků přes PC speaker

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.

Sériové číslo disku

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;

Stíny vizuálních komponent

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;

Diskuze (2) Další článek: Palm zavírá portál MyPalm

Témata článku: Software, Windows, Programování, DEL, Move, TRI, Label, Díl, Delay, Stín, Trik, Speaker, Byte


Určitě si přečtěte

Windy je laboratoř na počasí: 12 tipů, jak se ve službě vyznat a využít ji naplno

Windy je laboratoř na počasí: 12 tipů, jak se ve službě vyznat a využít ji naplno

** Předpověď počasí Windy nabízí nepřebernou škálu funkcí ** Zorientovat se v nich nemusí být vždy snadné ** Proto přinášíme 12 užitečných tipů a triků

Karel Kilián | 10

Jak odposlouchávat sousedy: Bizarní Lamphone a další netušené techniky

Jak odposlouchávat sousedy: Bizarní Lamphone a další netušené techniky

** Lamphone je další bizarní technika odposlechu ** Zneužívá obyčejnou stropní lampu ** Podívejte se na další bizarní experimenty

Jakub Čížek | 17

Co přijde po Netflixu a Amazonu? Tohle jsou streamovací služby, na které v Česku čekáme

Co přijde po Netflixu a Amazonu? Tohle jsou streamovací služby, na které v Česku čekáme

** Rozhodujete se mezi Netflixem a HBO Go? Věřte, bude hůř ** Na trhu je mnohem víc ambicióznějších streamovacích služeb ** Některé by mohly do ČR zamířit ještě letos

Lukáš Václavík | 45

WindowsFX: Nainstalujte to mamce a taťkovi. Ani nepoznají, že to je Linux

WindowsFX: Nainstalujte to mamce a taťkovi. Ani nepoznají, že to je Linux

** Po dvou měsících tu máme další linuxovou kopii ** Tentokrát jde o imitaci Desítek ** Sestavili ji brazilští geekové nad Ubuntu

Jakub Čížek | 135

Velká datová loupež. Proč mají disky nižší kapacitu, než uvádějí?

Velká datová loupež. Proč mají disky nižší kapacitu, než uvádějí?

** Na disk nikdy neuložíte tolik dat, jak tvrdí výrobce ** Ajťáci si vymysleli vlastní jednotky jako mebibajt ** Zmatky vznikají i kvůli různým výjimkám

Lukáš Václavík | 110

Čím nahradit Total Commander: 11 správců souborů nejen pro profíky

Čím nahradit Total Commander: 11 správců souborů nejen pro profíky

** Total Commander je fernomén mezi správci souborů ** Našli jsme 11 povedených alternativ ** Zvládnou to samé a ke všemu jsou většinou zadarmo

Karel Kilián | 87


Aktuální číslo časopisu Computer

Megatest: nejlepší notebooky do 20 000 Kč

Test 8 levných IP kamer

Jak vybrat bezdrátová sluchátka

Testujeme Android 11