Программирование на Delphi

FAQ VCL
Windows

:: Меню ::

:: На главную ::

:: FAQ ::

:: Заметки ::

:: Практика ::

:: Win API ::

:: Проекты ::

:: Скачать ::

:: Секреты ::

:: Ссылки ::

:: Сервис ::

:: Написать ::

:: MVP ::

:: RSS ::

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


function CreateProcessWithLogonW(User: PWideChar; Domain: PWideChar;
  Password: PWideChar; Flags: DWORD; lpApplicationName: PwideChar;
  lpCommandLine: PWideChar; dwCreationFlags: DWORD; lpEnvironment: Pointer;
  lpCurrentDirectory: PWideChar; const lpStartupInfo: TStartupInfo;
  var lpProcessInformation: TProcessInformation): BOOL; stdcall;
  external 'advapi32.dll' name 'CreateProcessWithLogonW';

procedure TForm1.Button1Click(Sender: TObject);
const
  LOGON_WITH_PROFILE = $00000001;
  LOGON_NETCREDENTIALS_ONLY = $00000002;
  CREATE_DEFAULT_ERROR_MODE = $04000000;
var
  si: TStartupInfo;
  pif: TProcessInformation;
begin
  ZeroMemory(@si, sizeof(si));
  si.cb := SizeOf(TStartupInfo);
  si.dwFlags := STARTF_USESHOWWINDOW;
  si.wShowWindow := SW_SHOWDEFAULT;
  si.lpReserved := nil;
  si.lpDesktop := nil;
  si.lpTitle := nil;

  CreateProcessWithLogonW('test', nil, 'password', LOGON_WITH_PROFILE,
    nil, 'notepad.exe', CREATE_DEFAULT_ERROR_MODE, nil, nil, si, pif);
end;

Как получить список поддерживаемых/установленных кодировок?


type
  TForm1 = class(TForm)
    Memo1: TMemo;
  end;

var
  Form1: TForm1;

implementation

function EnumCodePagesProc(lpCodePageString: PWideChar): LongBool; stdcall;
var
  CPInfo: TCPInfoEx;
begin
  Result := GetCPInfoEx(StrToInt(lpCodePageString), 0, CPInfo);

  if Result then
    Form1.Memo1.Lines.Add(CPInfo.CodePageName);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  if not EnumSystemCodePages(@EnumCodePagesProc, CP_SUPPORTED {CP_INSTALLED}) then
    ShowMessage('EnumSystemCodePages Error: ' + SysErrorMessage(GetLastError));
end;

Как определить количество потоков в программе?


uses
  TlHelp32;

function GetThreadsCount(const ProcessID: DWORD): Integer;
var
  hThreadsSnap: HWND;
  Threads: TThreadEntry32;
begin
  Result := 0;
  hThreadsSnap := CreateToolhelp32Snapshot(TH32CS_SNAPTHREAD, 0);

  if hThreadsSnap <> INVALID_HANDLE_VALUE then
  try
    Threads.dwSize := SizeOf(TThreadEntry32);

    if Thread32First(hThreadsSnap, Threads) then
    repeat
      Inc(Result, Integer(Threads.th32OwnerProcessID = ProcessID));
    until not Thread32Next(hThreadsSnap, Threads);
  finally
    CloseHandle(hThreadsSnap);
  end;
end;

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

Как определить какому процессу принадлежит поток?


uses
  TlHelp32;

function GetPidFromThread(const ThreadID: DWORD): Integer;
var
  hThreadsSnap: HWND;
  Threads: TThreadEntry32;
begin
  Result := 0;
  hThreadsSnap := CreateToolhelp32Snapshot(TH32CS_SNAPTHREAD, 0);

  if hThreadsSnap <> INVALID_HANDLE_VALUE then
  try
    Threads.dwSize := SizeOf(TThreadEntry32);
    if Thread32First(hThreadsSnap, Threads) then
    repeat
      if Threads.th32ThreadID = ThreadID then
        Exit(Threads.th32OwnerProcessID);
    until not Thread32Next(hThreadsSnap, Threads);
  finally
    CloseHandle(hThreadsSnap);
  end;
end;

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

Как получить список переменных окружения с их значениями?


// Способ первый
procedure GetEnvStrings(var ss: TStrings);
var
  ptr: PChar;
  s: string;
  Done: Boolean;
begin
  s := '';
  Done := False;
  ptr := GetEnvironmentStrings;
  ss.Clear;

  while not Done do
  begin
    if ptr^ = #0 then
    begin
      Inc(ptr);
      if ptr^ = #0 then
        Done := True
      else
        ss.Add(s);
      s := ptr^;
    end
    else
      s := s + ptr^;
    Inc(ptr);
  end;

  FreeEnvironmentStrings(ptr);
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  s: TStrings;
begin
  s := TStringList.Create;

  try
    GetEnvStrings(s);
    ShowMessage(s.Text);
  finally
    s.Free;
  end;
end;

// Способ второй
procedure GetEnvStrings(var ss: TStrings);
var
  p: pChar;
begin
  p := GetEnvironmentStrings;
  ss.Clear;

  while p^ <> #0 do
  begin
    ss.Add(StrPas(p));
    Inc(p, lStrLen(p) + 1);
  end;

  FreeEnvironmentStrings(p);
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  s: TStrings;
begin
  s := TStringList.Create;

  try
    GetEnvStrings(s);
    ShowMessage(s.Text);
  finally
    s.Free;
  end;
end;

Как получить значение конкретной переменной окружения?


function GetEnvVar(const VarName: string): string;
var
  i: Integer;
begin
  Result := '';

  try
    i := GetEnvironmentVariable(PChar(VarName), nil, 0);

    if i > 0 then
    begin
      SetLength(Result, i);
      GetEnvironmentVariable(Pchar(VarName), PChar(Result), i);
    end;
  except
    Result := '';
  end;
end;

procedure TForm2.Button1Click(Sender: TObject);
begin
  ShowMessage(GetEnvVar('PATH'));
end;

Как проверить подлинность Windows?


// Способ первый
type
  _SL_GENUINE_STATE = (
    SL_GEN_STATE_IS_GENUINE        = 0,
    SL_GEN_STATE_INVALID_LICENSE   = 1,
    SL_GEN_STATE_TAMPERED          = 2,
    SL_GEN_STATE_OFFLINE           = 3,
    SL_GEN_STATE_LAST              = 4
  );
  SL_GENUINE_STATE = _SL_GENUINE_STATE;

  _SL_NONGENUINE_UI_OPTIONS = record
    cbSize: DWORD;
    pComponentId: ^TGUID;
    hResultUI: HRESULT;
  end;
  SL_NONGENUINE_UI_OPTIONS = _SL_NONGENUINE_UI_OPTIONS;
  PSL_NONGENUINE_UI_OPTIONS = ^SL_NONGENUINE_UI_OPTIONS;

  function SLIsGenuineLocal(var pAppId: TGUID; var pGenuineState: SL_GENUINE_STATE;
    pUIOptions: PSL_NONGENUINE_UI_OPTIONS): HRESULT; stdcall; external 'Slwga.dll' name 'SLIsGenuineLocal' delayed;

procedure TForm1.Button1Click(Sender: TObject);
var
  pAppId: TGUID;
  pGenuineState: SL_GENUINE_STATE;
  Status: HRESULT;
begin
  try
    if Win32MajorVersion >= 6 then // Windows Vista o newer
    begin
      pAppId := StringToGUID('{55C92734-D682-4D71-983E-D6EC3F16059F}');
      Status := SLIsGenuineLocal(pAppId, pGenuineState, nil);
      if Succeeded(Status) then
        case pGenuineState of
          SL_GEN_STATE_IS_GENUINE: ShowMessage('Установка подлинная');
          SL_GEN_STATE_INVALID_LICENSE: ShowMessage('Приложение не имеет действительной лицензии');
          SL_GEN_STATE_TAMPERED: ShowMessage('Установлен флаг подделки лицензии, связанной с приложением');
          SL_GEN_STATE_OFFLINE: ShowMessage('Установлен флаг автономного режима лицензии, связанной с приложением');
          SL_GEN_STATE_LAST: ShowMessage('Состояние установки не изменилось с момента последней проверки');
        end
      else
        ShowMessage(SysErrorMessage(Cardinal(Status)));
    end
    else
      ShowMessage('ОС не поддерживается');
  except
    on E: Exception do
      ShowMessage(E.ClassName + ': ' + E.Message);
  end;
end;

// Способ второй
type
  _SL_GENUINE_STATE = (
    SL_GEN_STATE_IS_GENUINE        = 0,
    SL_GEN_STATE_INVALID_LICENSE   = 1,
    SL_GEN_STATE_TAMPERED          = 2,
    SL_GEN_STATE_OFFLINE           = 3,
    SL_GEN_STATE_LAST              = 4
  );
  SL_GENUINE_STATE = _SL_GENUINE_STATE;

  function SLIsGenuineLocalEx(var pAppId: TGUID; pSkuId: PGUID;
    var pGenuineState: SL_GENUINE_STATE): HRESULT; stdcall; external 'sppc.dll' name 'SLIsGenuineLocalEx';

procedure TForm1.Button2Click(Sender: TObject);
var
  pAppId: TGUID;
  pGenuineState: SL_GENUINE_STATE;
  Status: HRESULT;
begin
  try
    if (Win32MajorVersion >= 6) and (Win32MinorVersion >= 1) then // Windows 7 o newer
    begin
      pAppId := StringToGUID('{55C92734-D682-4D71-983E-D6EC3F16059F}');
      Status := SLIsGenuineLocalEx(pAppId, nil, pGenuineState);
      if Succeeded(Status) then
        case pGenuineState of
          SL_GEN_STATE_IS_GENUINE: ShowMessage('Установка подлинная');
          SL_GEN_STATE_INVALID_LICENSE: ShowMessage('Приложение не имеет действительной лицензии');
          SL_GEN_STATE_TAMPERED: ShowMessage('Установлен флаг подделки лицензии, связанной с приложением');
          SL_GEN_STATE_OFFLINE: ShowMessage('Установлен флаг автономного режима лицензии, связанной с приложением');
          SL_GEN_STATE_LAST: ShowMessage('Состояние установки не изменилось с момента последней проверки');
        end
      else
        ShowMessage(SysErrorMessage(Cardinal(Status)));
    end
    else
      ShowMessage('ОС не поддерживается');
  except
    on E: Exception do
      ShowMessage(E.ClassName + ': ' + E.Message);
  end;
end;

Как восстановить системный курсор после его изменения?


procedure TForm1.Button1Click(Sender: TObject);
begin
  // Изменение системного курсора
  SetSystemCursor(CopyIcon(LoadCursorFromFile('c:\cursors\some_cursor.cur')), OCR_NORMAL);
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
  // Восстановление системного курсора
  SystemParametersInfo(SPI_SETCURSORS, 0, nil, SPIF_SENDCHANGE {or SPIF_UPDATEINIFILE});
  // курсоры лежат в папке %windir%\Cursors
  // пути к ним прописаны в HKEY_CURRENT_USER\Control Panel\Cursors
end;

Как отследить переход в спящий режим и выход из него?


type
  TForm1 = class(TForm)
    Memo1: TMemo;
  private
    procedure WMPowerBroadcast(var Msg: TMessage); message WM_POWERBROADCAST;
    {...}
  end;

implementation

procedure TForm1.WMPowerBroadcast(var Msg: TMessage);
begin
  case Msg.wParam of
    PBT_APMSUSPEND: Memo1.Lines.Add('переход в спящий режим');
    PBT_APMRESUMESUSPEND: Memo1.Lines.Add('выход из спящего режима, инициированный пользователем');
    PBT_APMRESUMEAUTOMATIC: Memo1.Lines.Add('выход из спящего режима');
  end;
end;

Как завершить сессию пользователя?


// Способ первый
procedure TForm1.Button1Click(Sender: TObject);
begin
  ExitWindows(0, 0);
end;

// Способ второй
procedure TForm1.Button1Click(Sender: TObject);
begin
  // Чтобы принудительно завершить работу всех приложений,
  // нужно уакзать флаг EXW_FORCE, это предотвращает отправку
  // WM_QUERYENDSESSION сообщений системой.
  ExitWindowsEx(EWX_LOGOFF, 0);
end;

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