Živě.cz o počítačích a internetu

Tipy a triky v Delphi, díl 62. - Detekce přepínání uživatelů

Jan Šindelář - 16.10.2002

Detekce přepínání uživatelů

Kdysi jsme si v našem seriálu ukazovali, jak detekovat vypnutí či restart systému, protože to je stav, který je pro aplikaci poměrně důležitý. Aplikace v takovém případě může reagovat uložením dat a podobně. S příchodem Windows XP, které jsou stále rozšířenější, se nám celá věc drobně zkomplikovala. Přibyla nám totiž funkce na přepínání uživatelů, kdy nedojde k odhlášení uživatele v pravém slova smyslu, ale jeho aplikace běží na pozadí dál, zatímco může pracovat jiný přihlášený uživatel. Tyto spuštěné aplikace normálně pracují a pro aktuálního uživatele nejsou viditelné ani přístupné. A právě toto přepínání mezi uživateli se naučíme detekovat, aby mohla naše aplikace příslušným způsobem reagovat. V běžných případech to zřejmě nebude vůbec nutné, ale pokud je vaše aplikace natolik speciální, že by přepnutí uživatele mohlo vadit (přistupuje například k nějakým sdíleným prostředkům), jistě se bude tato detekce hodit. Program pak může reagovat tak, že některé své funkce omezí nebo úplně vypne, dokud nedojde opět k přepnutí na původního uživatele.

Vytvoříme si proto malou ukázkovou aplikaci, která bude toto přepínání hlídat. Poslouží nám k tomu dvě funkce. První zařídí, aby aplikace dostávala od systému upozornění na změnu session (tu použijeme při spuštění programu), druhou funkcí zase toto upozorňování zrušíme (při ukončení programu). Ještě přidáme navíc funkci pro detekci čísla aktuální session. V konstantách budou uloženy názvy jednotlivých stavů session (a zřejmě nemá cenu je překládat do češtiny, takže je ponechávám v původní podobě) a všechny výpisy budou prováděny do komponenty Memo. Umístěte ji proto na prázdný formulář. Jelikož totiž po přepnutí uživatele nebudete mít k aplikaci přístup, bude záznam o této změně vypsán právě do komponenty Memo a po opětovném přepnutí zpět si můžete jednotlivé stavy prohlédnout. Poslední věcí je tlačítko, které rovněž přidejte na formulář. Po jeho stisku bude zobrazeno číslo session, což má v tomto případě spíše ukázkový charakter, protože budete vidět vždy jen vaší aktuální session (po přepnutí na jiného uživatele pochopitelně tlačítko nepůjde stisknout, protože neuvidíte vůbec samotnou aplikaci). V "ostrých" aplikacích však tato funkce své využití jistě najde a rovněž místo výpisu daných stavů do Memo se bude aplikace chovat jinak. A zde tedy již samotný kód. Pro dnešek opět kompletní unit pro snadnější zkopírování do Delphi.

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls;

const

  WM_WTSSESSION_CHANGE = $2B1;
  WTS_CONSOLE_CONNECT = 1;
  WTS_CONSOLE_DISCONNECT = 2;
  WTS_REMOTE_CONNECT = 3;
  WTS_REMOTE_DISCONNECT = 4;
  WTS_SESSION_LOGON = 5;
  WTS_SESSION_LOGOFF = 6;
  WTS_SESSION_LOCK = 7;
  WTS_SESSION_UNLOCK = 8;
  WTS_SESSION_REMOTE_CONTROL = 9;
  NOTIFY_FOR_THIS_SESSION = 0;
  NOTIFY_FOR_ALL_SESSIONS = 1;

type
  TForm1 = class(TForm)
    Memo1: TMemo;
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure FormCreate(Sender: TObject);
  private
    { Private declarations }
    FRegisteredSessionNotification : Boolean;
    procedure AppMessage(var Msg: TMSG; var HAndled: Boolean);
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$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.