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

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

:: Меню ::

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

:: FAQ ::

:: Заметки ::

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

:: Win API ::

:: Проекты ::

:: Скачать ::

:: Секреты ::

:: Ссылки ::

:: Сервис ::

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

:: MVP ::

:: RSS ::

Как запретить менять размеры формы, имеющей границы?


type
  TForm1 = class(TForm)
  protected
    procedure WMNCHitTest(var Msg: TWMNCHitTest); message WM_NCHITTEST;
  end;

implementation

procedure TForm1.WMNCHitTest(var Msg: TWMNCHitTest);
var
  HitCode: LongInt;
begin
  inherited;
  // Result = HTLEFT, HTRIGHT, HTTOP, HTTOPLEFT,
  //          HTTOPRIGHT, HTBOTTOM, HTBOTTOMLEFT, HTBOTTOMRIGHT
  if Msg.Result in  [HTLEFT..HTBOTTOMRIGHT] then
    Msg.Result := HTNOWHERE;
end;

Как прочитать командную строку?


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

// Способ второй
procedure TForm1.Button1Click(Sender: TObject);
begin
  ShowMessage(CmdLine);
end;

// Способ третий
procedure TForm1.Button1Click(Sender: TObject);
var
  i: Integer;
  s: string;
begin
  s := '';
  for i := 0 to ParamCount do
    s := Concat(s, ' ', ParamStr(i));
  ShowMessage(TrimLeft(s));
end;

Как очистить командную строку от параметров?


type
  TForm1 = class(TForm)
  protected
    procedure CreateWnd; override;
  end;

implementation

// функция вычищает параметры запуска,
// оставляя только значение равное ParamStr(0)
procedure ClearCommandLine;
var
  p: PChar;
  i, Len: Integer;
begin
  p := GetCommandLineW;

  while True do
  begin
    while (p[0] <> #0) and (p[0] <= ' ') do
      Inc( p );

    if (P[0] = '"') and (p[1] = '"') then
      Inc(p{, SizeOf(Char)})
    else
      Break;
  end;

  while p[0] > ' ' do
  begin
    if p[0] = '"' then
    begin
      Inc(p);
      while (p[0] <> #0) and (p[0] <> '"') do
        Inc(p);
      if P[0] <> #0 then
        Inc(p);
    end
    else
      Inc(p);
  end;

  Len := lstrlenW(p);
  for i := 0 to Pred(Len) do
  begin
    P^ := #0;
    Inc(p);
  end;
end;

procedure TForm1.CreateWnd;
begin
  ClearCommandLine;
  inherited;
end;

Как подменить нажатие клавиши ENTER на нажатие клавиши TAB?


// Способ первый
type
  TForm1 = class(TForm)
  private
    procedure CMDialogKey( var Msg: TWMKey ); message CM_DIALOGKEY;
  end;

{...}

implementation

// Чтобы ускорить работу приложения,
// не надо активизировать свойство формы KEYPREVIEW
procedure TForm1.CMDialogKey(var Msg: TWMKey);
begin
  // Исключаем срабатывания подмены для кнопки
  if not (ActiveControl is TButton) then
    if Msg.Charcode = 13 then
      Msg.Charcode := 9;
  inherited;
end;

// Способ второй
// KeyPreview = True
procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
var
  ACtrl: TWinControl;
begin
  if Key = 13 then
  begin
    ACtrl := ActiveControl;
    if ACtrl is TCustomMemo then
      Exit;
    repeat
      ACtrl:= FindNextControl(ACtrl, True, True, False);
    until (ACtrl is TCustomEdit) or
          (ACtrl is TCustomComboBox) or
          (ACtrl is TCustomListBox) or
          (ACtrl is TCustomCheckBox) or
          (ACtrl is TRadioButton);
    ACtrl.SetFocus;
  end;
end;

Как определить, есть ли в exe (на Delphi) отладочная информация?


function IsHasDebugInfo: Boolean;
var
  fs: TFilestream;
  signature: DWORD;
  sl: TStringList;
  dos_header: IMAGE_DOS_HEADER;
  pe_header: IMAGE_FILE_HEADER;
  opt_header: IMAGE_OPTIONAL_HEADER;
  sec_header: IMAGE_SECTION_HEADER;
  sec_count, sec_current: Cardinal;
begin
  Result := False;

  fs := TFilestream.Create(Application.ExeName, fmOpenread or fmShareDenyNone);
  try
    fs.Read(dos_header, SizeOf(dos_header));
    if dos_header.e_magic <> IMAGE_DOS_SIGNATURE then
      Exit;

    fs.Seek(dos_header._lfanew, soFromBeginning);
    fs.Read(signature, SizeOf(signature));
    if signature <> IMAGE_NT_SIGNATURE then
      Exit;

    fs.Read(pe_header, SizeOf(pe_header));
    if pe_header.SizeOfOptionalHeader > 0 then
      fs.Read(opt_header, SizeOf(opt_header));

    sec_count := pe_header.NumberOfSections;
    sec_current := 0;

    sl := TStringList.Create;
    try
      while sec_current < sec_count do
      begin
        fs.Read(sec_header, SizeOf(sec_header));
        sl.Add(PAnsiChar(@sec_header.Name[0]));
        Inc(sec_current);
      end;

      Result := sl.IndexOf('.debug') >= 0;
    finally
      sl.Free;
    end;
  finally
    fs.Free;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  if IsHasDebugInfo then
    ShowMessage('Это отладочный файл');
end;

Как программе перезапустить саму себя?


// Способ первый
uses
  ShellAPI;

procedure TMainForm.Button1Click(Sender: TObject);
begin
  ShellExecute(0, 'open', PWideChar(Application.ExeName), nil, nil, SW_SHOWNORMAL);
  Close;
end;

// Способ первый
uses
  ShellAPI;

var
  NeedRestart: Boolean = False;

procedure TMainForm.Button1Click(Sender: TObject);
begin
  NeedRestart := True;
  Close;
end;

procedure TMainForm.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  // Флаг NeedRestart указывает на необходимость перезапуска программы
  // и продотвращает бесконечное зацикливание.
  if NeedRestart then
    ShellExecute(0, 'open', PWideChar(Application.ExeName), nil, nil, SW_SHOWNORMAL);
end;

Как, зная Handle окна программы, определить имя EXE-файла?


uses
  Tlhelp32;

function GetFileNameByHandle(hWnd: THandle): string;

  function GetExeNameByProcID(ProcID: DWORD): string;
  var
    ContinueLoop: BOOL;
    FSnapshotHandle: THandle;
    FProcessEntry32: TProcessEntry32;
  begin
    FSnapshotHandle := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);

    FProcessEntry32.dwSize := SizeOf(FProcessEntry32);

    ContinueLoop := Process32First(FSnapshotHandle, FProcessEntry32);

    Result := '';
    while (Integer(ContinueLoop) <> 0) and (Result = '') do
    begin
      if FProcessEntry32.th32ProcessID = ProcID then
        Result := FProcessEntry32.szExeFile;
      ContinueLoop := Process32Next(FSnapshotHandle, FProcessEntry32);
    end;
  end;

var
  pProcID: ^DWORD;
begin
  GetMem(pProcID, SizeOf(DWORD));
  GetWindowThreadProcessId(hWnd, pProcID);

  Result := GetExeNameByProcID(pProcID^);
end;

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

Как программе узнать откуда она запущена?


// Способ первый
procedure TForm1.Button1Click(Sender: TObject);
begin
  ShowMessage(ExtractFilePath(Application.ExeName));
end;

// Способ второй
procedure TForm1.Button1Click(Sender: TObject);
begin
  ShowMessage(ExtractFilePath(ParamStr(0)));
end;

// Способ третий
procedure TForm1.Button1Click(Sender: TObject);
begin
  ShowMessage(ExtractFilePath(GetModuleName(HInstance)));
end;

// Способ четвертый
procedure TForm1.Button1Click(Sender: TObject);
var
  ModuleFileName: string;
  Buffer: array[0..MAX_PATH] of Char;
begin
  SetString(ModuleFileName, Buffer, GetModuleFileName(HInstance {MainInstance},
    Buffer, SizeOf(Buffer)));
  ShowMessage(ExtractFilePath(ModuleFileName));
end;

Как получить handle окна, владеющего фокусом ввода?


function GetFocusedWindow: HWND;
var
  CurrThID, ThID: DWORD;
begin
  Result := GetForegroundWindow;
  if Result <> 0 then
  begin
    CurrThID := GetCurrentThreadId;
    ThID := GetWindowThreadProcessId(Result, nil);
    Result := 0;
    if CurrThID = ThId then
      Result := GetFocus
    else
    begin
      if AttachThreadInput(CurrThID, ThID, True) then
      begin
        Result := GetFocus;
        AttachThreadInput(CurrThID, ThID, False);
      end;
    end;
  end;
end;

procedure TForm1.Timer1Timer(Sender: TObject);
var
  h: HWND;
  buff: array[0..255] of Char;
  ClassName: string;
begin
  h := GetFocusedWindow;
  GetClassName(h, buff, SizeOf(buff));
  ClassName := StrPas(buff);
  Caption := ClassName + ' [' + IntToStr(h) + ']';
end;

Как отслеживать изменение свойства FormStyle?


// Способ первый
type
  TForm1 = class(TForm)
  private
    procedure WMCreate(var Msg: TWMCreate); message WM_CREATE;
  end;

implementation

uses
  TypInfo;

procedure TForm1.WMCreate(var Msg: TWMCreate);
begin
  Caption := Format('Style: %s, Handle: %s',
    [GetEnumName(TypeInfo(TFormStyle), Ord(FormStyle)),
     IntToStr(Handle)]) ;
end;

// Способ второй
type
  TForm1 = class(TForm)
  private
    procedure WMStyleChanged(var Msg: TWMStyleChanged); message WM_STYLECHANGED;
  end;

implementation

uses
  TypInfo;

procedure TForm1.WMStyleChanged(var Msg: TWMStyleChanged);
begin
  Caption := Format('Style: %s, Handle: %s',
    [GetEnumName(TypeInfo(TFormStyle), Ord(FormStyle)),
     IntToStr(Handle)]) ;
end;

// Способ третий
type
  TForm1 = class(TForm)
  private
    procedure WMChangeUIState(var Msg: TWMChangeUIState); message WM_CHANGEUISTATE;
  end;

implementation

uses
  TypInfo;

procedure TForm1.WMChangeUIState(var Msg: TWMChangeUIState);
begin
  Caption := Format('Style: %s, Handle: %s',
    [GetEnumName(TypeInfo(TFormStyle), Ord(FormStyle)),
     IntToStr(Handle)]) ;
end;

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