Tipy a triky v Delphi, díl 42.

V dnešním dílu se nejprve trochu podíváme na zoubek obrázku na tlačítku start a poté si ukážeme, jak změnit nudný kurzor v podobě svislé čáry v komponentě Edit podle vlastních představ.

Změna obrázku tlačítka Start

Už dlouho jsme se nepokoušeli nějak "potrápit" Windows, takže si to tímto tipem zase trošku vynahradíme. Změna obrázku na tlačítku Start sice není dvakrát užitečná záležitost, ale proč se trošku nepobavit.

Nejprve si vytvořte vhodný obrázek patřičných rozměrů (mně se osvědčily rozměry přibližně 48 x 16 pixelů) a pak již stačí jen použít následující kód:

.
.
.
private
    { Private declarations }
      StartButton : hWnd;
      OldBitmap : THandle;
      NewImage : TPicture;
.
.
.

procedure TForm1.Button1Click(Sender: TObject);
begin
NewImage := TPicture.Create;
NewImage.LoadFromFile(`start.bmp`);
StartButton := FindWindowEx(FindWindow(`Shell_TrayWnd`, nil), 0, `Button`, nil);
OldBitmap := SendMessage(StartButton, BM_SetImage, 0, NewImage.Bitmap.Handle);
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
    try
        SendMessage(StartButton, BM_SetImage, 0, OldBitmap);
        NewImage.Free;
    except end;
end;

Změna obrázku je opět vyvolána jako událost stisku tlačítka, a abychom nebyli na Windows tak zlí, po ukončení příkladu se vše vrátí do původního stavu v události OnDestroy formuláře.

Nutno připomenout, že Windows se brání seč můžou a tento příklad bude fungovat jen na "starší generaci", tj. Windows 9x. Pod Windows NT/2000 se zobrazí pouze prázdné tlačítko.

Další vylepšení komponenty Edit

A máme tu další vylepšení komponenty Edit. Abych se přiznal, jako odchovanec osmibitových počítačů a dalších podobných staříků jsem měl moc rád, když kurzor při zadávání textu měl podobu blikajícího čtverečku a ve Windows (a dalších systémech) používaná svislá "čárka" se mi moc nelíbí. Ukážeme si teď, jak u komponenty Edit tento svislý a poněkud nudný kurzor změnit.

Umístěte si tedy na formulář nějaký EditBox a pak přidejte následující kód:

.
.
.
public
  { Public declarations }
  CaretBm : TBitmap;
  CaretBmBk : TBitmap;
  OldEditsWindowProc : Pointer;
.
.
.
type
  WParameter = LongInt;
  LParameter = LongInt;
.
.
.
function NewWindowProc(WindowHandle : hWnd; TheMessage : WParameter; ParamW : WParameter; ParamL : LParameter) : LongInt stdcall;
begin
  NewWindowProc := CallWindowProc(Form1.OldEditsWindowProc, WindowHandle, TheMessage, ParamW, ParamL);
  if TheMessage = WM_SETFOCUS then
  begin
  CreateCaret(WindowHandle, Form1.CaretBm.Handle, 0, 0);
  ShowCaret(WindowHandle);
  end;
  if TheMessage = WM_KILLFOCUS then
  begin
  HideCaret(WindowHandle);
  DestroyCaret;
  end;
  if TheMessage = WM_KEYDOWN then
  begin
  if ParamW = VK_BACK then
    CreateCaret(WindowHandle, Form1.CaretBmBk.Handle, 0, 0) else
    CreateCaret(WindowHandle, Form1.CaretBm.Handle, 0, 0);
  ShowCaret(WindowHandle);
  end;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  CaretBm := TBitmap.Create;
  CaretBm.Canvas.Font.Name := `WingDings`;
  CaretBm.Canvas.Font.Height := Edit1.Font.Height;
  CaretBm.Canvas.Font.Color := clWhite;
  CaretBm.Width := CaretBm.Canvas.TextWidth(`J`) + 2;
  CaretBm.Height := CaretBm.Canvas.TextHeight(`J`) + 2;
  CaretBm.Canvas.Brush.Color := clBlue;
  CaretBm.Canvas.FillRect(Rect(0, 0, CaretBm.Width, CaretBm.Height));
  CaretBm.Canvas.TextOut(1, 1, `J`);
{-----------------------------------------------------------------}
  CaretBmBk := TBitmap.Create;
  CaretBmBk.Canvas.Font.Name := `WingDings`;
  CaretBmBk.Canvas.Font.Height := Edit1.Font.Height;
  CaretBmBk.Canvas.Font.Color := clWhite;
  CaretBmBk.Width := CaretBmBk.Canvas.TextWidth(`L`) + 2;
  CaretBmBk.Height := CaretBmBk.Canvas.TextHeight(`L`) + 2;
  CaretBmBk.Canvas.Brush.Color := clBlue;
  CaretBmBk.Canvas.FillRect(Rect(0, 0, CaretBmBk.Width, CaretBmBk.Height));
  CaretBmBk.Canvas.TextOut(1, 1, `L`);
  OldEditsWindowProc := Pointer(SetWindowLong(Edit1.Handle, GWL_WNDPROC, LongInt(@NewWindowProc)));
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
SetWindowLong(Edit1.Handle, GWL_WNDPROC, LongInt(OldEditsWindowProc));
CaretBm.Free;
CaretBmBk.Free;
end;

Funkce NewWindowProc se vlastně stará o celé řízení samotného psaní textu, stará se o reakce na focus a na stisknutí kláves. Jako kurzor (či spíše kurzory – viz dále) se používá "obrázek", vytvořený v události OnCreate hlavního formuláře. Ta má dvě části, které jsou pro přehlednost odděleny čárou. První část popisuje vizuální podobu kurzoru při psaní textu, druhá část zase stejným způsobem nastavuje podobu kurzoru při mazání textu klávesou Backspace.

A jak tedy celý výsledek vypadá? Kurzor je jednak vykreslen ve tvaru "kostičky" a jako třešnička na dortu (a spíše z důvodů demonstračních než pro reálné použití) se na něm zobrazuje během psaní smějící se "smajlík" ze znakové sady WingDings. V případě mazání textu klávesou Backspace se smajlík změní na zamračeného.

Myslím, že princip samotné tvorby kurzoru je dostatečně zřejmý, takže se nebojte experimentování.

Váš názor Další článek: Projekt Centrum Internetu zahajuje provoz v Brně

Témata článku: Software, Windows, Programování, Obrázek, TRI, Trik, Kostička, Pointer, DEL, Díl


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

Vážně dnes ještě někdo krade Adobe? Video můžete stříhat zdarma v Resolve a fotky i vektory zvládne Affinity

Vážně dnes ještě někdo krade Adobe? Video můžete stříhat zdarma v Resolve a fotky i vektory zvládne Affinity

** Kde jsou ty doby, kdy měl skoro každý doma Photoshop ** Photoshop a Premiere Pro od kamaráda nebo z warezu ** Dnes už to nemá smysl, existuje totiž hromada laciných alternativ

Jakub Čížek | 92

Jakub Čížek
Grafický editorStřih videa
Vy a počítač: Virtuální plochy ve Windows mají smysl, používá je třetina čtenářů
Vladislav Kluska
Jak používáte počítačWindows 10Ankety
Vodafonu se zhroutila kabelovka. Síť bývalého UPC má výpadky
Lukáš Václavík
VodafoneUPC
Vybíráme nejlepší monitory: Od úplně levných až po displeje na rozmazlování očí

Vybíráme nejlepší monitory: Od úplně levných až po displeje na rozmazlování očí

** Vybrali jsme nejlepší monitory na práci i pořádné hraní ** Nejlevnější monitor s kvalitním panelem nestojí ani tři tisíce ** Rozlišení 4K a větší obrazovka už není nedostupný luxus

David Polesný | 31

David Polesný
Monitory
Čekali jsme skoro šest let. Android Auto jede do Česka i na Slovensko
Lukáš Václavík
Android AutoNavigaceGoogle
Archivovat data do cloudu, na HDD, SSD, DVD, nebo Blu-ray? Co je nejvýhodnější?

Archivovat data do cloudu, na HDD, SSD, DVD, nebo Blu-ray? Co je nejvýhodnější?

** Kam doma natrvalo uložit data? Vyplatí se ještě optická média? ** Jaké kapacity disků a médií má smysl koupit? ** Cenovou výhodnost si ukážeme na příkladech s 2TB úložištěm

Lukáš Václavík | 125

Lukáš Václavík
ZálohováníÚložištěPevné disky