Sunday, September 30, 2007

Obrázkový ComboBox

Ukážeme si, jak vylepšit klasický ComboBox tím, že k jednotlivým položkám rozbaleného seznamu přiřadíme obrázky (ikonky). Každá položka pak bude mít vlevo vlastní ikonu a vedle ní bude samotný text dané položky.
Jak toho dosáhnout? Poměrně snadno tím, že se o vykreslení budeme starat sami prostřednictvím události OnDrawItem. Nejprve je však třeba nastavit styl ComboBoxu na csOwnerDrawFixed nebo csOwnerDrawVariable (podle toho, zda budou jednotlivé řádky mít fixní či proměnlivou velikost).
Poté naplňte ComboBox nějakými testovacími daty. Prostě několik řádků hodnot. Jednotlivé obrázky budou potom k položkám přiřazeny z ImageListu, který rovněž přidejte na formulář a pochopitelně naplňte několika (vhodně malými) obrázky.

Labels:

Saturday, September 29, 2007

Dále následuje část deklarace:

.
.
.
procedure FormCreate(Sender: TObject);
procedure WndProc(var Message: TMessage); override;
procedure Showform1Click(Sender: TObject);
procedure FormDestroy(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
IconNotifyData : TNotifyIconData;
end;
.
.
.
Procedura WndProc "odchytává" pokus o minimalizaci aplikace a zařídí její minimalizaci do ikony hlavního panelu. Zároveň se stará o reakce na kliknutí myší na ikonu – buď aplikaci obnoví nebo zobrazí PopupMenu.
procedure TForm1.WndProc(var Message: TMessage);
var
p : TPoint;
begin
case Message.Msg of
WM_SYSCOMMAND:
case Message.WParam and $FFF0 of
SC_MINIMIZE:
begin
Hide;
Exit;
end;
SC_RESTORE: ;
end;
WM_USER + 1:
case Message.lParam of
WM_RBUTTONDOWN:
begin
GetCursorPos(p);
PopupMenu1.Popup(p.x, p.y);
end;
WM_LBUTTONDOWN:
begin
Show;
end;
end;
end;
inherited ;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
with IconNotifyData do
begin
hIcon := Application.Icon.Handle;
uCallbackMessage := WM_USER + 1;
cbSize := sizeof(IconNotifyData);
Wnd := Handle;
uID := 100;
uFlags := NIF_MESSAGE + NIF_ICON + NIF_TIP;
end;
StrPCopy(IconNotifyData.szTip, Application.Title);
Shell_NotifyIcon(NIM_ADD, @IconNotifyData);
Application.ShowMainForm := False;
SetWindowLong(Application.Handle, GWL_EXSTYLE, WS_EX_TOOLWINDOW);
end;

procedure TForm1.Showform1Click(Sender: TObject);
begin
Show;
SetForegroundWindow(Self.handle);
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
Shell_NotifyIcon(NIM_DELETE, @IconNotifyData);
end;
Jako text bublinkové nápovědy u ikony je použit titulek aplikace – viz řádek StrPCopy(IconNotifyData... v události OnCreate hlavního formuláře, ale můžete jej pochopitelně libovolně měnit.
Jak vidíte, přidat si ikonku na hlavní panel není složité ani pracné. I když je tento příklad velmi jednoduchý a má sloužit spíše jako ukázka, základní funkce plní. Přidat některá další vylepšení však není problém. Pokud tedy místo použití hotových komponent dáváte přednost vlastní tvorbě, račte experimentovat.

Labels:

Friday, September 28, 2007

Dost ale zbytečných a nudných úvodů a pojďme k našemu příkladu. Po jeho spuštění bude aplikace ihned minimalizována, nebude vidět na hlavním panelu vedle tlačítka Start a zároveň se vedle hodin zobrazí příslušná ikonka. Po kliknutí na ni levým tlačítkem myši bude aplikace opět maximalizována (či přesněji řečeno, bude obnoveno hlavní okno do původního stavu), po kliknutí pravým tlačítkem se zobrazí kontextové menu.
Ještě je třeba upozornit, že budeme potřebovat knihovnu ShellAPI, takže ji nezapomeňte přidat do projektu. Vytvořte tedy nový projekt, přidejte zmíněnou knihovnu a také přidejte PopupMenu, v němž si můžete nadefinovat zcela libovolné položky (slouží pouze pro demonstraci).

Labels:

Wednesday, September 26, 2007

Ikona aplikace v hlavním panelu - tray icon

Jistě dobře víte, že řada aplikací se po svém spuštění "usídlí" v hlavním panelu vedle hodin v podobě malé ikonky. Obvykle se jedná o aplikace, které běží již od startu systému a vykonávají na pozadí nějaké funkce (antivirový program či různé další utility). Nevyžadují žádnou zvláštní pozornost uživatele a jejich hlavní okno by se tedy na ploše jen zbytečně pletlo. Zároveň však musí být jejich funkce občas přístupné a nebo je alespoň třeba indikovat, že daná aplikace běží. K tomu se právě ideálně hodí místo vedle hodin na hlavním panelu – tray. Tolik tedy teorie, ale praxe je bohužel trochu jiná, což sami jistě velmi dobře víte. Ikonu se na toto místo snaží "nacpat" kdejaká aplikace, takže někdy jich tam má uživatel slušnou řádku. Proto mi dovolte, ještě než si ukážeme jak touto ikonkou naše aplikace opatřit, jedno malé doporučení: dávat ikonu do hlavního panelu jen tehdy, když to má smysl (a ne proto, abyste ukázali, že to umíte). Také je dobré, aby o zobrazení či nezobrazení ikony mohl rozhodnout uživatel v nastavení programu.

Labels:

Monday, September 24, 2007

Spuštění aplikace pouze jednou v rámci dané instance Windows

Poněkud krkolomný nadpis, uznávám. Ale hned si vysvětlíme, oč se jedná. Vzpomínáte si, jak jsme si kdysi ukazovali, jak zamezit několikanásobnému spuštění aplikace? Tento příklad zase zajistí, že vaše aplikace bude spustitelná pouze jednou během aktuálního běhu Windows. Pokud bude někdo chtít vaši aplikaci spustit podruhé, bude muset nejprve Windows restartovat. K tomu nám poslouží funkce GlobalAddAtom a GlobalFindAtom. Využití tohoto příkladu ponechám na vás, jistě sami na něco přijdete.
procedure TForm1.FormShow(Sender : TObject);
var
Atom : integer;
begin
if GlobalFindAtom('TEXT_IDENTIFIKUJICI_NASI_APLIKACI') = 0 then Atom := GlobalAddAtom('TEXT_IDENTIFIKUJICI_NASI_APLIKACI')
else
begin
ShowMessage('Tato aplikace může být spuštěna pouze jednou za běhu Windows. Pro opětovné spuštění je třeba Windows restartovat');
Close;
end;
end;

Labels:

Saturday, September 22, 2007

Jak vidíte, zobrazení nápovědy je kvůli zjednodušení vyvoláno po stisku tlačítka, což není právě praktické, doplnit si zobrazování po najetí myší vám ovšem nechám za domácí úkol. Ale zpět k samotnému zobrazení. Nejprve je třeba u daného tlačítka vyplnit položku Hint, protože odtud je text brán. Také by bylo dobré deaktivovat původní hint (ShowHint := false), aby se nám nezobrazovaly nápovědy dvě.
Samotné parametry "okna" nápovědy si můžete upravit jednak přímo v události OnCreate hlavního formuláře, kde je nastaveno několik základních vizuálních vlastností. Zbytek najdete přímo v proceduře ShowAHint, která má čtyři parametry – souřadnice, kde se má nápověda zobrazit, text nápovědy a dobu, po jakou bude nápověda zobrazena. Velikost okna nápovědy (tedy vlastně Panelu) je upravena podle velikosti zobrazovaného textu, ale nic vám nebrání si velikost přizpůsobit. Rovněž si můžete sami upravit vlastnosti, jako je barva podkladu nápovědy (v našem příkladu zvolena dost kontrastní barva Lime) či barvu a parametry samotného textu.

Friday, September 21, 2007

A ještě jednou bublinková nápověda

A znovu tu máme téma bublinkové nápovědy. Tentokrát si vytvoříme přímo vlastní bublinkovou nápovědu (Hint), a to prostřednictvím komponenty Panel. Umístěte ji tedy na formulář. O její vlastnosti se nemusíte starat, budou měněny přímo programově. Dále bude potřeba jeden Timer, abychom náš Hint zobrazili na požadovaný časový interval. Poté si ještě na formulář umístěte jedno tlačítko, na kterém budeme funkčnost příkladu demonstrovat.
A nyní již samotný kód:
.
.
.
private
{ Private declarations }
procedure ShowAHint(x: integer; y: integer; Caption: string; Duration: LongInt);
.
.
.

procedure TForm1.FormCreate(Sender: TObject);
begin
Timer1.Enabled := false;
Panel1.Visible := false;
Panel1.BevelInner := bvNone;
Panel1.BevelOuter := bvNone;
Panel1.BorderStyle := bsSingle;
end;

procedure TForm1.ShowAHint(x : integer; y : integer; Caption : string; Duration : LongInt);
var
dc : hdc;
OldFont : hFont;
pt : TSize;
p : pChar;
begin
if Timer1.Enabled <> false then Timer1.Enabled := false;
Timer1.Enabled := false;
if Panel1.Visible <> false then Panel1.Visible := false;
if Caption = '' then exit;
Panel1.Caption := caption;
GetMem(p, Length(Panel1.Caption) + 1);
StrPCopy(p, Panel1.Caption);
dc := GetDc(Panel1.Handle);
OldFont := SelectObject(dc, Panel1.Font.Handle);
GetTextExtentPoint32(dc, p, Length(Panel1.Caption), pt);
SelectObject(dc, OldFont);
ReleaseDc(Panel1.Handle, Dc);
FreeMem(p, Length(Panel1.Caption) + 1);
Panel1.Left := x;
Panel1.Top := y;
Panel1.Width := pt.cx + 6;
Panel1.Height := pt.cy + 2;
Panel1.Color:= clLime;
Panel1.Font.Color := clBlue;
Panel1.Visible := true;
Timer1.Interval := Duration;
Timer1.Enabled := true;
end;

procedure TForm1.Timer1Timer(Sender: TObject);
begin
if Panel1.Visible <> false then
Panel1.Visible := false;
Timer1.Enabled := false;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
Application.ProcessMessages;
ShowAHint(Button1.Left, Button1.Top + Button1.Height + 6, Button1.Hint, 2000);
end;

Labels:

Tuesday, September 11, 2007

Proto ji umístěte na formulář

a dále vyplňte parametr FileName, který určuje název souboru, jehož první snímek chceme zobrazit. Nyní již stačí přidat tento jednoduchý kód a první snímek se zobrazí v okně MediaPlayeru:
procedure TForm1.Button1Click(Sender: TObject);
begin
Application.ProcessMessages;
MediaPlayer1.Open;
Application.ProcessMessages;
MediaPlayer1.Step;
Application.ProcessMessages;
MediaPlayer1.Previous;
end;

Labels:

Zobrazení prvního snímku videa

Pokud potřebujete vytvořit pouhý náhled a ne přehrát celé video, obvykle se k tomu používá první snímek, i když zrovna z prvního snímku nemusí být vždy zřejmé, oč se jedná. K jeho zobrazení použijeme komponentu MediaPlayer, čímž nám odpadne starost o všechny záležitosti související s prací se samotným video souborem. Můžeme tak zobrazit první snímek (frame) z téměř libovolného formátu videa, tedy přesněji řečeno z těch formátů, jejichž kodeky máme v systému nainstalovány. A o práci s nimi se právě postará komponenta MediaPlayer.

Labels:

Sunday, September 09, 2007

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í.

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;

Thursday, September 06, 2007

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.

Labels: ,

Wednesday, September 05, 2007

Úprava fontu bublinkové nápovědy

Bublinkovou nápovědou (Hint) jsme se již zabývali mnohokrát. Ukázali jsme si, jak se dá nastavit doba, po jaké se má objevit, barva a další parametry. Nyní si ukážeme vlastně poslední z chybějících nastavení a to je druh písma nápovědy.
.
.
.
implementation

{$R *.DFM}

Type
TMyHintWindow = Class (THintWindow)
Constructor Create (AOwner: TComponent); override;
end;

Constructor TMyHintWindow.Create (AOwner: TComponent);
Begin
Inherited Create (Aowner);
Canvas.Font.Name := 'Verdana';
Canvas.Font.Style:= [fsBold];
Canvas.Font.Size := 18;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
Application.ShowHint := False;
HintWindowClass := TMyHintWindow;
Application.ShowHint := True;
end;
.
.
.
Takto dosáhneme velkého a tučného fontu. Pravda, pro použití v reálu je poněkud nevhodný, ale jako ukázka ideální a vy si již určitě najdete vhodnou kombinaci. Někteří uživatelé jistě ocení, pokud jim nabídnete možnost zvolit si i takovýto drobný detail v nastavení aplikace.

Labels:

Sunday, September 02, 2007

Když nyní projekt znovu zkompilujete, komponenta ListView už bude fungovat pod Windows XP bez problémů a většina potenciálních problémů je tak vyřešena. Zkompilovanou knihovnu (soubor comctrls.dcu) můžete poté zkopírovat do složky Lib a přepsat tak originální knihovnu, aby tato upravená verze byla použita i ve všech dalších projektech.

Labels:

Soubor si nakopírujte do složky s vaší aplikací, otevřete jej a najděte si proceduru TCustomListView.UpdateColumn, kterou upravte podle tohoto vzoru (stačí, když celou původní proceduru přepíšete tou, která je uvedena níže, neboť je kompletní):
procedure TCustomListView.UpdateColumn(AnIndex: Integer);
const IAlignment: array[Boolean, TAlignment] of LongInt =
((LVCFMT_LEFT, LVCFMT_RIGHT, LVCFMT_CENTER),
(LVCFMT_RIGHT, LVCFMT_LEFT, LVCFMT_CENTER));
var
Column: TLVColumn;
AAlignment: TAlignment;
begin
if HandleAllocated then
with Column, Columns.Items[AnIndex] do
begin
mask := LVCF_TEXT or LVCF_FMT;
if FImageIndex >= 0 then mask := mask or LVCF_IMAGE;
iImage := FImageIndex;
pszText := PChar(Caption);
AAlignment := Alignment;
if Index <> 0 then
fmt := IAlignment[UseRightToLeftAlignment, AAlignment]
else fmt := LVCFMT_LEFT;
if FImageIndex <> -1 then
fmt := fmt or LVCFMT_IMAGE or LVCFMT_COL_HAS_IMAGES;
if WidthType > ColumnTextWidth then
begin
mask := mask or LVCF_WIDTH;
cx := FWidth;
ListView_SetColumn(Handle, Columns[AnIndex].FOrderTag, Column);
end
else begin
ListView_SetColumn(Handle, Columns[AnIndex].FOrderTag, Column);
if ViewStyle = vsList then
ListView_SetColumnWidth(Handle, -1, WidthType)
else if (ViewStyle = vsReport) and not OwnerData then
ListView_SetColumnWidth(Handle, Columns[AnIndex].FOrderTag, WidthType);
end;
end;
end;

Labels: