Программирование на 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)
  private
    procedure WMSettingChange(var Msg: TWMSettingChange); message WM_SETTINGCHANGE;
  public
    { Public declarations }
  end;

implementation

procedure TForm1.WMSettingChange(var Msg: TWMSettingChange);
const
  CM_CHANGEFORMAT = WM_USER + 101;
begin
   // Приложению нужно реагировать на изменения настроек из вне, для чего нужно обрабатывать
   // сообщение WM_SETTINGCHANGE, которое пришло на замену устаревшему WM_WININICHANGE. Получив
   // его нужно обновить свои собственные настройки, для чего посылаем сами себе сообщение
   // CM_CHANGEFORMAT. А вот изменятся они или нет зависит от настройки Application.UpdateFormatSettings
   // (по умолчанию True, изменятся).
   PostMessage(Handle, CM_CHANGEFORMAT, 0, 0);
   Msg.Result := 0;
   inherited;
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
   ss.Clear;
   s := '';
   Done := False;
   ptr := GetEnvironmentStrings;
   while Done = False 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;
   GetEnvStrings(s);
   ShowMessage(s.Text);
   s.Free;
end;

// Способ второй
procedure GetEnvStrings(var ss: TStrings);
var
  p: pChar;
begin
   ss.Clear;
   p := GetEnvironmentStrings;
   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;
   GetEnvStrings(s);
   ShowMessage(s.Text);
   s.Free;
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;

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