FAQ VCL
Форма (приложение)

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

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

:: MVP ::

:: RSS ::

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

Как определить параметры, с которыми процесс был создан?

procedure TForm1.Button1Click(Sender: TObject);
var
  StartupInfo: TStartupInfo;
begin
  GetStartupInfo(StartupInfo);
end;


Как определить, работает программа в терминальном режиме или нет?

function IsRemoteSession: Boolean;
begin
  Result := GetSystemMetrics(SM_REMOTESESSION) <> 0;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  case IsRemoteSession of
    True: ShowMessage('Терминальное подключение');
    False: ShowMessage('Локальное подключение');
  end;
end;


Как перехватить WM_SETTEXT с помощью подмены оконной процедуры?

type
  TForm1 = class(TForm)
    procedure FormCreate(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
  private
    oldWndProc: Pointer;
    procedure MyWndProc(var msg: TMessage);
  public
  end;

{...}

implementation

{...}

procedure TForm1.FormCreate(Sender: TObject);
begin
  oldWndProc := DefWndProc;
  DefWndProc := MakeObjectInstance(MyWndProc);
end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  FreeObjectInstance(DefWndProc);
  DefWndProc := oldWndProc;
end;

procedure TForm1.MyWndProc(var msg: TMessage);
begin
  if msg.Msg = WM_SETTEXT then
  begin
    // ...
  end;
  msg.Result := CallWindowProc(oldWndProc, Handle, msg.Msg, msg.WParam, msg.LParam);
end;


Как сохранить всю форму в файл (как Delphi в .dfm)?

constructor TForm1.Create(AOwner: TComponent);
begin
  { Для динамически создаваемых контролов, может требоваться RegisterClasses( [...] ); }
  RegisterClasses([TEdit, TMemo]);

  if FileExists('c:\form.txt') then
  begin
    CreateNew(AOwner);
    ReadComponentResFile('c:\form.txt', Self);
  end
  else
    inherited Create(AOwner);
end;

procedure TForm1.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
  WriteComponentResFile('c:\form.txt', Self);
end;


Как добиться того, что при клике мыши на форме она не становилась активной?

type
  TForm1 = class(TForm)
  private
    procedure WMMouseActivate(var Msg: TWMMouseActivate); message WM_MOUSEACTIVATE;
  end;

implementation

procedure TForm1.WMMouseActivate(var Msg: TWMMouseActivate);
begin
  inherited;
  Msg.Result := MA_NOACTIVATE;
end;


Как программно определить, запущена ли программа на 64-разрядной Windows?

function Is64BitWindows: Boolean;
var
  IsWow64Process: function(hProcess: THandle; out Wow64Process: BOOL): BOOL; stdcall;
  Wow64Process: BOOL;
begin
  {$IF Defined(CPUX64)}
  Result := True; // 64-битная программа запускается только на Win64
  //{$ELSEIF Defined(CPUX16)}
  //Result := False; // Win64 не поддерживает 16-разрядные приложения
  {$ELSE}
  // 32-битные программы могут работать и на 32-разрядной и на 64-разрядной Windows
  // так что этот вопрос требует дальнейшего исследования
  IsWow64Process := GetProcAddress(GetModuleHandle(Kernel32), 'IsWow64Process');

  Wow64Process := False;
  if Assigned(IsWow64Process) then
    Wow64Process := IsWow64Process(GetCurrentProcess, Wow64Process) and Wow64Process;

  Result := Wow64Process;
  {$ENDIF}
end;

// Для 32-х разрядного процесса в 64-х разрядной ОС будет установлена TRUE во втором параметре,
// для систем ниже WinXP (где нет смысла выяснять 64-х разрядность) будет ошибка ERROR_CALL_NOT_IMPLEMENTED,
// для 64-процесса и так всё ясно.


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

// Способ первый (консольное приложение)
uses
  {...,} ShellAPI;

procedure CrProcess(FileName, S, Dir, WindowName: string);
var
  SeInfo: TShellExecuteInfo;
  ExitCode: DWord;
begin
  FillChar(SEInfo, SizeOf(SEInfo), 0);

  with SEInfo do
  begin
    cbSize := SizeOf(TShellExecuteInfo);
    fmask := SEE_MASK_NOCLOSEPROCESS;
    Wnd := Application.Handle;
    lpFile := PChar('"' + FileName + '"');
    lpParameters := PChar(S);
    lpDirectory := nil;
    nShow := SW_HIDE;
  end;

  if ShellExecuteEx(@SEInfo) then
    repeat
      Application.ProcessMessages;
      GetExitCodeProcess(SEInfo.hProcess, ExitCode);
    until(FindWindow(nil, PChar(WindowName)) <> 0) or
         (ExitCode <> STILL_ACTIVE) or Application.Terminated
  else
    MessageDlg('Ошибка создания внешнего процесса. Код ошибки: ' + SysErrorMessage(GetLastError), mtError, [mbAbort], 0);

  CloseHandle(SEInfo.hProcess);
  if FindWindow(nil, PChar(WindowName)) <> 0 then
  begin
    SendMessage(FindWindow(nil, PChar(WindowName)), WM_CLOSE, 0, 0);
    while FindWindow(nil, PChar(WindowName)) <> 0 do
      Application.ProcessMessages;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  // Заархивировать
  // CrProcess('путь_к_архиваору_rar', 'a -r0 -m5 ' + 'имя_архива' + #32 + 'имя_каталога' + '*.*', TempPath, '(Сеанс завершен) - Rar');
  // Разархивировать
  // CrProcess('путь_к_архиваору_rar', 'x -y ' + 'имя_архива' + #32 + 'каталог_куда_разархивировать', '(Сеанс завершен) - Rar');
  CrProcess('d:\Program Files\WinRAR\Rar.exe', 'a -r0 -m5 ' + '"c:\test.rar"' + #32 + '"c:\test rar\"' + '*.*', '', '(Сеанс завершен) - Rar');
  CrProcess('d:\Program Files\WinRAR\Rar.exe', 'x -y ' + '"c:\test.rar"' + #32 + '"c:\test unrar\"', '', '(Сеанс завершен) - Rar');
end;

// Обратите внимание, используется альтернатива функции WaitForSingleObject(), собственная организация цикла.
// Процедура написана исходя из совместимости со старыми ДОС процессами. ДОС программы не оставляют код завершения
// своего процесса по коду STILL_ACTIVE, а поэтому в таком случае запуск процесса "повиснет", т.е. будет постоянно
// "крутится" в цикле Repeat .. Until(). Для таких случаев преднозначена переменная WindowName. Когда ДОС задача
// завершается, появляется окно "(Сеанс завершён)  - Имя_процесса". Используйте эту переменную, если вы запускаете
// ДОС программу, вписав при этом в эту переменную свою строку по аналогии. В этом случае цикл Repeat .. Until()
// оборвётся при наличии такого окна, т.е. когда процесс и завершится. До кучи ещё процедура закроет это окно, чтобы
// предотвратить проблему при многократных запусках.

// Способ второй (CreateProcess)
function ExecAndWait(const FileName, Params: ShortString; const WinState: Word): Boolean; export;
var
  StartInfo: TStartupInfo;
  ProcInfo: TProcessInformation;
  CmdLine: ShortString;
begin
  CmdLine := '"' + Filename + '" ' + Params;
  FillChar(StartInfo, SizeOf(StartInfo), #0);

  with StartInfo do
  begin
    cb := SizeOf(StartInfo);
    dwFlags := STARTF_USESHOWWINDOW;
    wShowWindow := WinState;
  end;
  Result := CreateProcess(nil, PChar(String(CmdLine)), nil, nil, false,
                          CREATE_NEW_CONSOLE or NORMAL_PRIORITY_CLASS, nil,
                          PChar(ExtractFilePath(Filename)), StartInfo, ProcInfo);

  { Ожидаем завершения приложения }
  if Result then
  begin
    WaitForSingleObject(ProcInfo.hProcess, INFINITE);
    CloseHandle(ProcInfo.hProcess);
    CloseHandle(ProcInfo.hThread);
  end;
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
  ExecAndWait('c:\Windows\System32\calc.exe', '', SW_SHOWNORMAL);
end;

// Способ третий (CreateProcess)
procedure TForm1.Button1Click(Sender: TObject);
var
  si: TStartupInfo;
  p: TProcessInformation;
begin
  FillChar(Si, SizeOf(si), 0);
  si.cb := SizeOf(si);
  Application.Minimize;
  Createprocess(nil, 'notepad.exe', nil, nil, False,
                CREATE_DEFAULT_ERROR_MODE, nil, nil, si, p);
  WaitForSingleObject(p.hProcess, INFINITE);
  CloseHandle(p.hProcess);
  Application.Restore;
end;

// Способ четвертый (CreateProcess)
procedure TForm1.Button1Click(Sender: TObject);
var
  si: TStartupInfo;
  p: TProcessInformation;
begin
  FillChar(si, SizeOf(si), 0);
  si.cb := SizeOf(si);
  if Createprocess(nil, 'notepad.exe', nil, nil, False, 0, nil, nil, si, p) then
  begin
    CloseHandle(p.hThread);
    Waitforsingleobject(p.hProcess, INFINITE);
    CloseHandle(p.hProcess);
  end;
end;

// Способ пятый (CreateProcess)
function ExecAndWait(const FileName, Params: string): Boolean;
var
  pi: TProcessInformation;
  si: TStartupInfo;
begin
  ZeroMemory(@si, SizeOf(si));
  si.cb := SizeOf(si);

  if not CreateProcess(PChar(FileName), PChar(Params), nil,
                       nil, False, 0, nil, nil, si, pi) then
  begin
    Result := False;
    RaiseLastWin32Error;
    Exit;
  end;

  WaitForSingleObject(pi.hProcess, INFINITE);
  CloseHandle(pi.hProcess);
  CloseHandle(pi.hThread);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  ExecAndWait('C:\winnt\system32\calc.exe', '');
end;

// А если заменить WaitForSingleObject(pi.hProcess, INFINITE); на
// while WaitforSingleObject(pi.hProcess, 200) = WAIT_TIMEOUT do
//   Application.ProcessMessages;
// то вызывающая программа не будет казаться завешанной
// и будет отвечать на сообщения

function ExecAndWait(const FileName, Params: string): Boolean;
var
  pi: TProcessInformation;
  si: TStartupInfo;
begin
  ZeroMemory(@si, SizeOf(si));
  si.cb := SizeOf(si);
  if not CreateProcess(PChar(FileName), PChar(Params), nil,
                       nil, False, 0, nil, nil, si, pi) then
  begin
    Result := False;
    RaiseLastWin32Error;
    Exit;
  end;

  while WaitforSingleObject(pi.hProcess, 200) = WAIT_TIMEOUT do
    Application.ProcessMessages;

  CloseHandle(pi.hProcess);
  CloseHandle(pi.hThread);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  ExecAndWait('C:\winnt\system32\calc.exe', '');
end;

// Способ шестой (ShellExecute)
uses
  {...,} ShellAPI;

procedure StartAndWait(Name: PChar);
var
  ProcInfo: PShellExecuteInfo;
begin
  GetMem(ProcInfo, SizeOf(ProcInfo^));

  with ProcInfo^ do 
  begin
    Wnd := Application.Handle;
    cbSize := SizeOf(ProcInfo^);
    lpFile := PChar(Name);
    lpParameters := nil;
    lpVerb := 'open';
    nShow := SW_SHOW;
    fMask := SEE_MASK_DOENVSUBST or SEE_MASK_NOCLOSEPROCESS;
  end;

  try
    Win32check(ShellExecuteEx(ProcInfo));
    while not Application.Terminated and (WaitForSingleObject(ProcInfo.hProcess, 100) = WAIT_TIMEOUT) do
      Application.ProcessMessages;
  finally
    if ProcInfo.hProcess <> 0 then
      CloseHandle(ProcInfo.hProcess);
    Dispose(ProcInfo);
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  (Sender as TControl).Enabled := False;
  StartAndWait('notepad.exe');
  (Sender as TControl).Enabled := True;
end;


Как найти окно по части его заголовка?

function FindWndByCaption(StartHWND: HWND; AString: string): HWND;
var
  Buffer: array [0..255] of Char;
begin
  Result := StartHWND;
  repeat
    Result := FindWindowEx(0, Result, nil, nil);
    GetWindowText(Result, Buffer, SizeOf(Buffer));
    if StrPos(PChar(AnsiUpperCase(Buffer)), PChar(AnsiUpperCase(AString))) <> nil then
      Break;
  until Result = 0;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  hW: HWND;
  Buffer: array [0..255] of Char;
begin
  hW := FindWndByCaption(0, 'Оплот');
  if hW > 0 then
  begin
    GetWindowText(hW, Buffer, SizeOf(Buffer));
    ShowMessage('Найдено окно: ' + Buffer);
  end;
end;


Как закрыть приложение с сообщением о фатальной ошибке?

// Способ первый
procedure TForm1.Button1Click(Sender: TObject);
begin
  FatalAppExit(0, 'Произошла неустранимая ошибка. ' +
               'Приложение будет закрыто. Пожалуйста, обратитесь в службу поддержки!');
  // Событие формы OnCloseQuery не вызывается при использовании функции FatalAppExit.
end;

// Способ второй
function Crash(Arg: Integer): Integer; stdcall;
begin
  Result := PInteger(nil)^;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  TID: Cardinal;
begin
  CloseHandle(CreateThread(nil, 0, @Crash, nil, 0, TID));
end;


Как узнать, программа запущена через ярлык (.lnk) или нет?

// Функция возвращает True, если приложение запустили через ярлык;
// False - в противном случае. Так же возвращает имя файла ярлыка (если доступно)
function GetShortcutName(out ALinkName: string): Boolean;
const
  STARTF_TITLESHORTCUT = $800;
var
  si: TStartupInfo;
begin
  FillChar(si, SizeOf(si), 0);
  si.cb := SizeOf(si);
  GetStartupInfo(si);

  if (si.dwFlags and STARTF_TITLESHORTCUT) <> 0 then
  begin
    ALinkName := si.lpTitle;
    Result := True;
  end
  else
    Result := False;
end;

procedure TForm1.Button2Click(Sender: TObject);
var
  LinkName: string;
begin
  if GetShortcutName(LinkName) then
    ShowMessage(LinkName);
end;

// Примечание:
// Всё сводится к проверке флага, но надо учитывать один момент:
// когда установлен флаг STARTF_TITLEISLINKNAME, поле lpTitle записи TStartupInfo
// указывает на строку, содержащую полный путь к файлу ярлыка, который использовался
// для запуска вашего приложения. К примеру, на вашем рабочем столе есть ярлык, который
// запускает Блокнот (notepad.exe). Когда запускается notepad.exe, то его
// TStartupInfo.lpTitle содержит такой текст:
// C:\Documents and Settings\James\Desktop\Notepad.lnk

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