FAQ VCL
Windows

:: Меню ::
:: На главную ::
:: FAQ ::
:: Заметки ::
:: Практика ::
:: Win API ::
:: Проекты ::
:: Скачать ::
:: Секреты ::
:: Ссылки ::

:: Сервис ::
:: Написать ::

:: MVP ::

:: RSS ::

Яндекс.Метрика

Как узнать имя пользователя?

// Способ первый
function GettingUserName: string;
var
  Size: Cardinal;
  pStr: PChar;
  Res: Boolean;
begin
  pStr := nil;
  Size := MAX_COMPUTERNAME_LENGTH + 1;
  try
    pStr := StrAlloc(Size);
    Res := GetUserName(pStr, Size);
    if Res then
      Result := StrPas(pStr)
    else
      Result := 'Имя пользователя неизвестно';
  finally
    if pStr <> nil then
      StrDispose(pStr);
  end;
end;

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

// Способ второй
const
  WTS_CURRENT_SERVER_HANDLE = THandle(0);

  WTSUserName = 5;

  function ProcessIdToSessionId(dwProcessId: DWORD; var pSessionId: DWORD): BOOL;
    stdcall; external 'Kernel32.dll' name 'ProcessIdToSessionId';

  function WTSQuerySessionInformationA(hServer: THandle; SessionId: DWORD;
    WTSInfoClass: DWORD; var ppBuffer: Pointer; var pBytesReturned: DWORD
    ): BOOL; stdcall; external 'wtsapi32.dll' name 'WTSQuerySessionInformationA';

  procedure WTSFreeMemory(pMemory: Pointer); stdcall;
    external 'wtsapi32.dll' name 'WTSFreeMemory';

procedure TForm1.Button1Click(Sender: TObject);
var
  BufSize: Cardinal;
  pBuf: PAnsiChar;
  pSessionId: DWORD;
  Result: string;
begin
  ProcessIdToSessionId(GetCurrentProcessId, pSessionId);
  // или pSessionId := DWORD(-1);
  if WTSQuerySessionInformationA(WTS_CURRENT_SERVER_HANDLE, pSessionId,
    WTSUserName, Pointer(pBuf), BufSize) then
  try
    SetString(Result, pBuf, BufSize);
    ShowMessage(Result);
  finally
    WTSFreeMemory(pBuf);
  end;
end;


Как узнать имя компьютера?

// Способ первый
function GettingComputerName: string;
var
  Size: Cardinal;
  pStr: PChar;
  Res: Boolean;
begin
  pStr := nil;
  Size := MAX_COMPUTERNAME_LENGTH + 1;
  try
    pStr := StrAlloc(Size);
    Res := GetComputerName(pStr, Size);
    if Res then
      Result := StrPas(pStr)
    else
      Result := 'Имя компьютера неизвестно';
  finally
    if pStr <> nil then
      StrDispose(pStr);
  end;
end;

// Способ второй
uses
  {...,} WinSock;

function GetLocalName: string;
var
  WSAData: TWSAData;
  Buf: array [0..127] of AnsiChar;
begin
  Result := '';
  if WSAStartup($101, WSAData) = 0 then
  try
    if GetHostName(@Buf, SizeOf(Buf)) = 0 then
      Result := Buf;
  finally
    WSACleanup;
  end;
end;


Как получить путь к директории Windows?

function TForm1.GettingWinDirectory: string;
var
  Size: Cardinal;
  pStr: PChar;
begin
  pStr := nil;
  Size := MAX_COMPUTERNAME_LENGTH + 1;
  try
    pStr := StrAlloc(Size);
    GetWindowsDirectory(pStr, Size);
    Result := pStr;
  finally
    if pStr <> nil then
      StrDispose(pStr);
  end;
end;


Как получить хэндл рабочего стола для манипуляций иконками?

// Способ первый
function GetHandle: HWND;
begin
  // Находим нужное окно в три этапа
  Result := FindWindow('Progman', 'Program Manager');
  // Используем FindWindowEx для нахождения дочернего окна
  Result := FindWindowEx(Result, HWND(nil), 'SHELLDLL_DefView', nil);
  // SysListView32, это список с иконками на рабочем столе
  Result := FindWindowEx(Result, HWND(nil), 'SysListView32', nil);
end;

// Способ второй
function GetHandle: HWND;
var
  s: string;
begin
  // Находим нужное окно в три этапа
  Result := FindWindow('Progman', 'Program Manager');
  // Нахождим дочернее окно
  Result := GetWindow(Result, GW_CHILD);
  // Нахождим дочернее окно
  Result := GetWindow(Result, GW_CHILD);
  SetLength(s, 40);
  GetClassName(Result, PChar(s), 39);
  if PChar(s) <> 'SysListView32' then
    Result := 0;
end;


Как отследить факт изменения системного времени?

type
  TForm1 = class(TForm)
  private
    { Private declarations }
    procedure WMTIMECHANGE(var Message: TWMTIMECHANGE);
    message WM_TIMECHANGE;
  public
    { Public declarations }
  end;

procedure TForm1.WMTIMECHANGE(var Message: TWMTIMECHANGE);
begin
  Caption := 'Системное время изменено';
end;


Как в Windows2000 получить список пользователей?

{$EXTERNALSYM NetUserEnum}
function NetUserEnum(servername: LPWSTR; level, filter: DWORD;
                     bufptr: Pointer; prefmaxlen: DWORD;
                     entriesread, totalentries, resume_handle: LPDWORD): DWORD; stdcall;
external 'NetApi32.dll' Name 'NetUserEnum';

function NetApiBufferFree(Buffer: Pointer): DWORD; stdcall;
external 'NetApi32.dll' Name 'NetApiBufferFree';

var
  Form1: TForm1;
  UserList: TStringList;

// Процедура возвращает список пользователей 
// локального хоста (Windows NT, Windows 2000)
procedure TForm1.GetLocalUserList(ulist: TStringList);
const
  NERR_SUCCESS = 0;
  FILTER_TEMP_DUPLICATE_ACCOUNT = $0001;
  FILTER_NORMAL_ACCOUNT = $0002;
  FILTER_PROXY_ACCOUNT = $0004;
  FILTER_INTERDOMAIN_TRUST_ACCOUNT = $0008;
  FILTER_WORKSTATION_TRUST_ACCOUNT = $0010;
  FILTER_SERVER_TRUST_ACCOUNT = $0020;
type
  TUSER_INFO_10 = record
     usri10_name,
     usri10_comment,
     usri10_usr_comment,
     usri10_full_name: PWideChar;
  end;
  PUSER_INFO_10 = ^TUSER_INFO_10;
var
  dwERead, dwETotal, dwRes, res: DWORD;
  inf: PUSER_INFO_10;
  info: Pointer;
  p: PChar;
  i: Integer;
begin
  if ulist = nil then
    Exit;
  ulist.Clear;

  info := nil;
  dwRes := 0;
  res := NetUserEnum(nil, 10, FILTER_NORMAL_ACCOUNT, @info,
                     65536, @dwERead, @dwETotal, @dwRes);
  if (res <> NERR_SUCCESS) or (info = nil) then
    Exit;
  p := PChar(info);
  for i := 0 to dwERead-1 do
  begin
    inf := PUSER_INFO_10(p + i * SizeOf(TUSER_INFO_10));
    ulist.Add(WideCharToString( PWideChar((inf^).usri10_name)));
  end;

  NetApiBufferFree(info);
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  i: Integer;
begin
  Memo1.Clear;
  UserList := TStringList.Create;
  GetLocalUserList(UserList);
  for i := 0 to UserList.Count-1 do
    Memo1.Lines.Add(UserList.Strings[i]);
  UserList.Free;
end;


Как определить разрешение экрана?

Memo1.Lines.Add(IntToStr(Screen.Width));
Memo1.Lines.Add(IntToStr(Screen.Height));


Как проверить, включён ли ActiveDesktop?

function IsActiveDeskTopOn: Boolean;  
var
  h: hWnd;
begin
  h := FindWindow('Progman', nil);
  h := FindWindowEx(h, 0, 'SHELLDLL_DefView', nil);
  h := FindWindowEx(h, 0, 'Internet Explorer_Server', nil);
  Result := h <> 0;
end;


Как отследить изменения настроек дисплея?

type
  TForm1 = class(TForm)
  private
    { Private declarations }
    procedure WMDisplayChange(var Message: TMessage); message WM_DISPLAYCHANGE;
  public
    { Public declarations }
  end;

procedure TForm1.WMDisplayChange(var Message: TMessage);
begin
  inherited;
  ShowMessage('Настройки экрана изменены');
end;


Как определить, включено ли автоскрытие у панели задач?

uses
  {...,} ShellAPI;

function IsTaskbarAutoHideOn: Boolean;
var
  ABData: TAppBarData;
begin
  ABData.cbSize := sizeOf(ABData);
  Result := (SHAppBarMessage(ABM_GETSTATE, ABData) and ABS_AUTOHIDE) > 0;
end;

При использовании материала - ссылка на сайт обязательна