Tipy a triky v Delphi

Tipy a triky v Delphi
Do třetice zde máme tip pro Windows XP a opět se bude týkat bublinkové nápovědy - hintů. Tentokrát ale té běžné, která se zobrazuje u všech prvků uživatelského prostředí.
Windows XP nám kromě nových funkcí přinášejí řadu novinek uživatelského prostředí. Kromě "skinů", vyhlazování fontů a různých dalších efektů, týkajících se všech možných prvků prostředí, jsme si minule ukazovali i nové balónové hinty. Jestli jsou všechny tyto efekty přínosem, to je věc názoru. První věcí, kterou velká část uživatelů udělá, je to, že tyto efekty prostě vypne. Toto je ovšem téma na úplně jiný článek, i když budu rád, pokud svůj názor vyjádříte v diskusi pod článkem. Vraťme se však k Delphi. I dnes si budeme povídat o hintech, tedy o bublinkové nápovědě, ale tentokrát té klasické, kterou obsahují (či mohou obsahovat) již od pradávna všechny (tedy téměř) prvky uživatelského prostředí systému.
I u tohoto poměrně jednoduchého prvku nám Windows XP přinášejí rovněž vylepšení vzhledu. Pokud ji do svých programů zapracujete a necháte aktivované příslušné volby vzhledu v samotném systému, budou pak vypadat hinty o malý chloupek lépe než dosud. Změna spočívá v přidání poměrně efektního, i když možná na první pohled snadno přehlédnutelného, stínu k samotnému popisku. Tím vypadá nápověda ještě o něco lépe a vyvolává mnohem plastičtější dojem.

Zajímavá je taktéž procedura SysTrayIconMsgHandler, která má na starosti zpracování zpráv o stavu nápovědy. V naší ukázce nejsou jednotlivým stavům přiřazeny žádné akce, takže si příslušné funkce doplňte dle vaší potřeby sami. Jak vidíte ze zdrojového kódu, jsou zde reakce na stisknutí tlačítka myši, skrytí či zobrazení nápovědy, uplynutí timeoutu a podobně.
A na závěr snad už jen poznámka k drobným rozdílům mezi systémy. Zatímco pod Windows XP bude zobrazena nápověda v "plné síle" včetně uzavíracího tlačítka a s efektem postupného zobrazování a pohasínání, pod Windows 2000 bude toto tlačítko i efekt chybět. Nemám představu, jak bude situace vypadat pod Windows ME, ale předpokládám že stejně jako pod Windows 2000. A konečně pod Windows 98 (či staršími systémy) se nezobrazí nic, pouze ikona v hlavním panelu a varovné upozornění, které je tam pochopitelně pouze pro naše testovací účely a v opravdových aplikacích není samozřejmě nutné tímto dialogem uživatele obtěžovat.

type
PNewNotifyIconData = ^TNewNotifyIconData;
TDUMMYUNIONNAME = record
case Integer of
0: (uTimeout: UINT);
1: (uVersion: UINT);
end;

TNewNotifyIconData = record
cbSize: DWORD;
Wnd: HWND;
uID: UINT;
uFlags: UINT;
uCallbackMessage: UINT;
hIcon: HICON;
szTip: array [0..127] of Char;
dwState: DWORD;
dwStateMask: DWORD;
szInfo: array [0..255] of Char;
DUMMYUNIONNAME: TDUMMYUNIONNAME;
szInfoTitle: array [0..63] of Char;
dwInfoFlags: DWORD;
end;


type
TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
private
IconData: TNewNotifyIconData;
procedure SysTrayIconMsgHandler(var Msg: TMessage); message TRAY_CALLBACK;
procedure AddSysTrayIcon;
procedure ShowBalloonTips;
procedure DeleteSysTrayIcon;
public
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.SysTrayIconMsgHandler(var Msg: TMessage);
begin
case Msg.lParam of
WM_MOUSEMOVE:;
WM_LBUTTONDOWN:;
WM_LBUTTONUP:;
WM_LBUTTONDBLCLK:;
WM_RBUTTONDOWN:;
WM_RBUTTONUP:;
WM_RBUTTONDBLCLK:;
NIN_BALLOONSHOW:;
NIN_BALLOONHIDE:;
NIN_BALLOONTIMEOUT:;
NIN_BALLOONUSERCLICK:;
end;
end;

procedure TForm1.AddSysTrayIcon;
begin
IconData.cbSize := SizeOf(IconData);
IconData.Wnd := AllocateHWnd(SysTrayIconMsgHandler);
IconData.uID := 0;
IconData.uFlags := NIF_ICON or NIF_MESSAGE or NIF_TIP;
IconData.uCallbackMessage := TRAY_CALLBACK;
IconData.hIcon := Application.Icon.Handle;
IconData.szTip := 'Toto je testovací nápověda.';
if not Shell_NotifyIcon(NIM_ADD, @IconData) then ShowMessage('Chyba, nepodařilo se vložit ikonu do hlavního panelu !');
end;

procedure TForm1.ShowBalloonTips;
var
TipInfo, TipTitle: string;
begin
IconData.cbSize := SizeOf(IconData);
IconData.uFlags := NIF_INFO;
TipInfo := 'Toto je testovací nápověda.';
strPLCopy(IconData.szInfo, TipInfo, SizeOf(IconData.szInfo) - 1);
IconData.DUMMYUNIONNAME.uTimeout := 3000;
TipTitle := 'Upozornění';
strPLCopy(IconData.szInfoTitle, TipTitle, SizeOf(IconData.szInfoTitle) - 1);
IconData.dwInfoFlags := NIIF_INFO;
Shell_NotifyIcon(NIM_MODIFY, @IconData);
IconData.DUMMYUNIONNAME.uVersion := NOTIFYICON_VERSION;
if not Shell_NotifyIcon(NIM_SETVERSION, @IconData) then ShowMessage('Chyba ve verzi.');
end;

procedure TForm1.DeleteSysTrayIcon;
begin
DeallocateHWnd(IconData.Wnd);
if not Shell_NotifyIcon(NIM_DELETE, @IconData) then ShowMessage('Chyba, nepodařilo se odstranit ikonu z hlavního panelu.');
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
AddSysTrayIcon;
ShowBalloonTips;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
DeleteSysTrayIcon;
end;

end.
Při úpravě kódu je pro vás důležitá hlavně procedura ShowBalloonTips, kde najdete jednak texty, které se budou v nápovědě zobrazovat (tedy nadpis a vlastní zpráva) a dále také typ ikony. Ta je v ukázce nastavena na NIIF_INFO, tedy informační ikona. Další možnosti můžete najít v konstantách, jsou to NIIF_WARNING a NIIF_ERROR a jistě sami dobře víte, jaké ikony budou tyto názvy představovat. Rovněž zde najdete i časový interval (timeout), jak dlouho bude bublina zobrazena, ale rovnou se vám přiznám, že je třeba brát tento údaj s rezervou, neboť se nápověda zobrazí vždy na o něco delší okamžik (tedy alespoň na mém počítači).

Tipy a triky v Delphi

I dnešní tip bude poněkud zaměřen na Windows XP, i když příklad by vám měl fungovat i v jiných verzích. Budeme se zabývat "balónovými hinty".
Tzv. balónové hinty, tedy poněkud vylepšená klasická bublinková nápověda, která se objevuje u ikon na hlavním panelu vedle hodin, se ve větší míře začaly objevovat až s příchodem Windows XP, i když v jisté omezené míře fungují i pod Windows 2000 či ME (stejně jako náš dnešní příklad).
Kromě výrazně změněného vzhledu samotné "bubliny", která teď už vypadá skutečně jako komiksová bublina, se drobně odlišuje i text. Bublina obsahuje jednak jakýsi nadpis, který je napsán tučněji než samotný text a pak pochopitelně samotnou zprávu uživateli, která může být několikařádková. Dále je zde drobná ikonka, symbolizující druh zprávy (podobně jako u klasických message dialogů) a rovněž tlačítko na uzavření tohoto malého "okna". Ale dost popisu, všichni víte, oč se jedná.
Náš příklad tedy ve zkratce provede to, že po spuštění se přidá do hlavního panelu ikonka naší aplikace a zobrazí se balónový hint s krátkým textem. Po uplynutí zadaného času (nastaven na 3 sekundy) nebo kliknutí uživatele pak nápověda zmizí.
unit Unit1;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, ShellAPI;

const
NIF_INFO = $10;
NIF_MESSAGE = 1;
NIF_ICON = 2;
NOTIFYICON_VERSION = 3;
NIF_TIP = 4;
NIM_SETVERSION = $00000004;
NIM_SETFOCUS = $00000003;
NIIF_INFO = $00000001;
NIIF_WARNING = $00000002;
NIIF_ERROR = $00000003;
NIN_BALLOONSHOW = WM_USER + 2;
NIN_BALLOONHIDE = WM_USER + 3;
NIN_BALLOONTIMEOUT = WM_USER + 4;
NIN_BALLOONUSERCLICK = WM_USER + 5;
NIN_SELECT = WM_USER + 0;
NINF_KEY = $1;
NIN_KEYSELECT = NIN_SELECT or NINF_KEY;
TRAY_CALLBACK = WM_USER + $7258;

{$R *.dfm}

function RegisterSessionNotification(Wnd: HWND; dwFlags: DWORD): Boolean;
type
TWTSRegisterSessionNotification = function(Wnd: HWND; dwFlags: DWORD): BOOL; stdcall;
var
hWTSapi32dll: THandle;
WTSRegisterSessionNotification: TWTSRegisterSessionNotification;
begin
Result := False;
hWTSAPI32DLL := LoadLibrary('Wtsapi32.dll');
if (hWTSAPI32DLL > 0) then
begin
try
@WTSRegisterSessionNotification := GetProcAddress(hWTSAPI32DLL, 'WTSRegisterSessionNotification');
if Assigned(WTSRegisterSessionNotification) then Result := WTSRegisterSessionNotification(Wnd, dwFlags);
finally
if hWTSAPI32DLL > 0 then FreeLibrary(hWTSAPI32DLL);
end;
end;
end;

function UnRegisterSessionNotification(Wnd: HWND): Boolean;
type
TWTSUnRegisterSessionNotification = function(Wnd: HWND): BOOL; stdcall;
var
hWTSapi32dll: THandle;
WTSUnRegisterSessionNotification: TWTSUnRegisterSessionNotification;
begin
Result := False;
hWTSAPI32DLL := LoadLibrary('Wtsapi32.dll');
if (hWTSAPI32DLL > 0) then
begin
try
@WTSUnRegisterSessionNotification := GetProcAddress(hWTSAPI32DLL, 'WTSUnRegisterSessionNotification');
if Assigned(WTSUnRegisterSessionNotification) then Result:= WTSUnRegisterSessionNotification(Wnd);
finally
if hWTSAPI32DLL > 0 then FreeLibrary(hWTSAPI32DLL);
end;
end;
end;

function GetCurrentSessionID: Integer;
type
TProcessIdToSessionId = function(dwProcessId: DWORD; pSessionId: DWORD): BOOL; stdcall;
var
ProcessIdToSessionId: TProcessIdToSessionId;
Lib : THandle;
pSessionId : DWord;
begin
Result := 0;
Lib := GetModuleHandle('kernel32');
if Lib <> 0 then
begin
ProcessIdToSessionId := GetProcAddress(Lib, '1ProcessIdToSessionId');
if Assigned(ProcessIdToSessionId) then
begin
ProcessIdToSessionId(GetCurrentProcessId(), DWORD(@pSessionId));
Result:= pSessionId;
end;
end;
end;

procedure TForm1.AppMessage(var Msg: TMSG; var Handled: Boolean);
var
strReason: string;
begin
Handled := False;
if Msg.Message = WM_WTSSESSION_CHANGE then
begin
case Msg.wParam of
WTS_CONSOLE_CONNECT: strReason := 'WTS_CONSOLE_CONNECT';
WTS_CONSOLE_DISCONNECT: strReason := 'WTS_CONSOLE_DISCONNECT';
WTS_REMOTE_CONNECT: strReason := 'WTS_REMOTE_CONNECT';
WTS_REMOTE_DISCONNECT: strReason := 'WTS_REMOTE_DISCONNECT';
WTS_SESSION_LOGON: strReason := 'WTS_SESSION_LOGON';
WTS_SESSION_LOGOFF: strReason := 'WTS_SESSION_LOGOFF';
WTS_SESSION_LOCK: strReason := 'WTS_SESSION_LOCK';
WTS_SESSION_UNLOCK: strReason := 'WTS_SESSION_UNLOCK';
WTS_SESSION_REMOTE_CONTROL: strReason := 'WTS_SESSION_REMOTE_CONTROL';
else
strReason := 'WTS_Unknown';
end;
Memo1.Lines.Add(strReason + ' ' + IntToStr(msg.Lparam));
end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
ShowMessage(IntToStr(GetCurrentSessionID));
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
if FRegisteredSessionNotification then UnRegisterSessionNotification(Handle);
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
FRegisteredSessionNotification := RegisterSessionNotification(Handle, NOTIFY_FOR_THIS_SESSION);
Application.OnMessage := AppMessage;
end;

end.
A zbývá jen poslední informace, týkající se ostatních systémů Windows. Není třeba se obávat žádných chybových hlášení, program vybavený těmito funkcemi bude fungovat i na starších systémech, ale tyto funkce pochopitelně nebudou mít žádný efekt.