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

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

:: Меню ::

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

:: FAQ ::

:: Заметки ::

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

:: Win API ::

:: Проекты ::

:: Скачать ::

:: Секреты ::

:: Ссылки ::

:: Сервис ::

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

:: MVP ::

:: RSS ::

Как изменить шрифт и выравнивание в заголовке формы?


// Способ первый
type
  TForm1 = class(TForm)
  public
    procedure WMNCPaint(var Msg: TWMNCPaint); message WM_NCPAINT;
  end;

procedure TForm1.WMNCPaint(var Msg: TWMNCPaint);
var 
  ACanvas: TCanvas; 
begin 
  inherited;
  ACanvas := TCanvas.Create;
  try
    ACanvas.Handle := GetWindowDC(Form1.Handle);
    with ACanvas do
    begin
      Brush.Color := clActiveCaption;
      Font.Name := 'Tahoma';
      Font.Size := 8;
      Font.Color := clred;
      Font.Style := [fsItalic, fsBold];
      TextOut(GetSystemMetrics(SM_CYMENU) + GetSystemMetrics(SM_CXBORDER),
              Round((GetSystemMetrics(SM_CYCAPTION) - Abs(Font.Height)) / 2) + 1,
              'Some Text');
    end;
  finally
    ReleaseDC(Form1.Handle, ACanvas.Handle);
    ACanvas.Free;
  end;
end;

// Способ второй
type
  TForm1 = class(TForm)
    procedure FormPaint(Sender: TObject);
    procedure FormResize(Sender: TObject);
    procedure FormActivate(Sender: TObject);
    procedure FormDeactivate(Sender: TObject);
    {...}
  end;

procedure TForm1.FormPaint(Sender: TObject);
var 
  LabelHeight, LabelWidth, LabelTop: Integer;
  CaptionHeight, Border3d_y, ButtonWidth, BorderThickness: Integer;
  MyCanvas: TCanvas; 
  CaptionBarRect: TRect; 
begin
  CaptionBarRect := Rect(0, 0, 0, 0);
  MyCanvas := TCanvas.Create;
  MyCanvas.Handle := GetWindowDC(Form1.Handle);
  Border3d_y := GetSystemMetrics(SM_CYEDGE);
  ButtonWidth := GetSystemMetrics(SM_CXSIZE);
  BorderThickness := GetSystemMetrics(SM_CYSIZEFRAME);
  CaptionHeight := GetSystemMetrics(SM_CYCAPTION);
  LabelWidth := Form1.Canvas.TextWidth(Form1.Caption);
  LabelHeight := Form1.Canvas.TextHeight(Form1.Caption);
  LabelTop := LabelHeight - (CaptionHeight div 2);
  CaptionBarRect.Left := BorderThickness + Border3d_y + ButtonWidth;
  CaptionBarRect.Right := Form1.Width - (BorderThickness + Border3d_y) - (ButtonWidth * 4) + 20;
  CaptionBarRect.Top := BorderThickness + Border3d_y;
  CaptionBarRect.Bottom := CaptionHeight;
  if Form1.Active then
    MyCanvas.Brush.Color := clActiveCaption
  else
    MyCanvas.Brush.Color := clInActiveCaption;
  MyCanvas.Brush.Style := bsSolid;
  MyCanvas.FillRect(CaptionBarRect);
  MyCanvas.Brush.Style := bsClear;
  MyCanvas.Font.Color := clRed;
  MyCanvas.Font.Name := 'Tahoma';
  MyCanvas.Font.Style := MyCanvas.Font.Style + [fsBold, fsItalic];
  DrawText(MyCanvas.Handle, PChar(' ' + Form1.Caption), Length(Form1.Caption) + 1,
           CaptionBarRect, DT_CENTER or DT_SINGLELINE or DT_VCENTER);
  MyCanvas.Free;
end;

procedure TForm1.FormResize(Sender: TObject);
begin
  Form1.Paint;
end;

procedure TForm1.FormActivate(Sender: TObject);
begin
  Form1.Paint;
end;

procedure TForm1.FormDeactivate(Sender: TObject);
begin
  Form1.Paint;
end;

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


type
  TForm1 = class(TForm)
  private
    procedure CreateParams(var Params: TCreateParams); override;
    {...}
  end;

procedure TForm1.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params);
  with Params do
    ExStyle := ExStyle or WS_EX_RIGHT;
end;

Как имитировать появление формы как нового приложения?


type
  TForm1 = class(TForm)
  private
    procedure CreateParams(var Params: TCreateParams); override;
    {...}
  end;

procedure TForm1.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params);
  with Params do
    ExStyle := ExStyle or WS_EX_APPWINDOW;
end;

Как среагировать на минимизацию, максимизацию и восстановление формы перед тем как это произойдет?


type
  TForm1 = class(TForm)
  private
    procedure WMSysCommand(var Msg: TWMSysCommand); message WM_SYSCOMMAND;
    {...}
  end;

procedure TForm1.WMSysCommand(var Msg: TWMSysCommand);
begin
  case Msg.CmdType of
    SC_MINIMIZE: ShowMessage('Minimize');
    SC_MAXIMIZE: ShowMessage('Maximize');
    SC_RESTORE: ShowMessage('Restore');
  end;
  inherited;
end;

// К сожалению это не сработает при нажатии кнопки на панели задач

Как определить, нажат ли Shift при старте приложения?


program Project1;

uses
  Forms,
  Windows,
  Dialogs,
  Unit1 in 'Unit1.pas' {Form1};

var
  KeyState: TKeyBoardState;

{$R *.res}

begin
  Application.Initialize;
  GetKeyboardState(KeyState);
  if ((KeyState[vk_Shift] and 128) <> 0) then
    ShowMessage('Вы запустили программу, удерживая клавишу Shift');
  Application.CreateForm(TForm1, Form1);
  Application.Run;
end.

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


// Способ первый
procedure TForm1.Button1Click(Sender: TObject);
var 
  BatchFile: TextFile; 
  BatchFileName: string; 
  ProcessInfo: TProcessInformation; 
  StartUpInfo: TStartupInfo; 
begin 
  // Создаем bat-файл в директории приложения
  BatchFileName := ExtractFilePath(ParamStr(0)) + '$$336699.bat';
  // Открываем и записываем в файл
  AssignFile(BatchFile, BatchFileName);
  Rewrite(BatchFile);
  Writeln(BatchFile, ':try');
  Writeln(BatchFile, 'del "' + ParamStr(0) + '"');
  Writeln(BatchFile, 'if exist "' + ParamStr(0) + '"' + ' goto try');
  Writeln(BatchFile, 'del "' + BatchFileName + '"');
  CloseFile(BatchFile);
  FillChar(StartUpInfo, SizeOf(StartUpInfo), $00);
  StartUpInfo.dwFlags := STARTF_USESHOWWINDOW;
  StartUpInfo.wShowWindow := SW_HIDE;
  if CreateProcess(nil, PChar(BatchFileName), nil, nil, False,
                   IDLE_PRIORITY_CLASS, nil, nil, StartUpInfo, ProcessInfo) then
  begin
    CloseHandle(ProcessInfo.hThread);
    CloseHandle(ProcessInfo.hProcess);
  end;
end;

// Способ второй
procedure TForm1.Button1Click(Sender: TObject);
var
  BatchFile: TextFile;
  BatchFileName: string;
  TM: Cardinal;
  TempMem: PChar;
begin
  BatchFileName := ExtractFilePath(ParamStr(0)) + '$$336699.bat';
  AssignFile(BatchFile, BatchFileName);
  Rewrite(BatchFile);
  Writeln(BatchFile, ':try');
  Writeln(BatchFile, 'del "' + ParamStr(0) + '"');
  Writeln(BatchFile, 'if exist "' + ParamStr(0) + '" goto try');
  Writeln(BatchFile, 'del "' + BatchFileName + '"');
  CloseFile(BatchFile);
  TM := 70;
  GetMem(TempMem, TM);
  GetShortPathName(PChar(BatchFileName), TempMem, TM);
  BatchFileName := TempMem;
  FreeMem(TempMem);
  WinExec(PChar(BatchFileName), SW_HIDE);
  Halt;
end;

// Способ третий
uses
  {...,} ShellApi;

procedure TForm1.FormDestroy(Sender: TObject);
var
  f: TextFile;
  FileName: string;
begin
  FileName := ChangeFileExt(ParamStr(0), '.bat');
  AssignFile(f, FileName);
  Rewrite(f);
  Writeln(f, ':1');
  Writeln(f, Format('Erase "%s"', [ParamStr(0)]));
  Writeln(f, Format('If exist "%s" Goto 1', [ParamStr(0)]));
  Writeln(f, Format('Erase "%s"', [FileName]));
  CloseFile(f);
  ShellExecute(Handle, 'Open', PChar(FileName), nil, nil, SW_HIDE);
end;

// Способ четвертый
procedure DeleteEXE;

  function GetTmpDir: string;
  var
    pc: PChar;
  begin
    pc := StrAlloc(MAX_PATH+1);
    GetTempPath(MAX_PATH, pc);
    Result := string(pc);
    StrDispose(pc);
  end;

  function GetTmpFileName(ext: string): string;
  var
    pc: PChar;
  begin
    pc := StrAlloc(MAX_PATH+1);
    GetTempFileName(PChar(GetTmpDir), 'uis', 0, pc);
    Result := string(pc);
    Result := ChangeFileExt(Result, ext);
    StrDispose(pc);
  end;

var
  BatchFile: TStringList;
  BatchName: string;
begin
  BatchName := GetTmpFileName('.bat');
  FileSetAttr(ParamStr(0), 0);
  BatchFile := TStringList.Create;
  with BatchFile do
  begin
    try
      Add(':Label1');
      Add('del "' + ParamStr(0) + '"');
      Add('if Exist "' + ParamStr(0) + '" goto Label1');
      Add('rmdir "' + ExtractFilePath(ParamStr(0)) + '"');
      Add('del ' + BatchName);
      SaveToFile(BatchName);
      ChDir(GetTmpDir);
      ShowMessage('Сейчас программа будет удалена');
      WinExec(PChar(BatchName), SW_HIDE);
    finally
      BatchFile.Free;
    end;
    Halt;
  end;
end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  DeleteEXE;
end;

// Способ пятый
procedure TForm1.Button1Click(Sender: TObject);
var
  module: HModule;
  buf: array[0..MAX_PATH-1] of char;
  p: ULong;
  hKrnl32: HModule;
  pExitProcess,
  pDeleteFile,
  pFreeLibrary: pointer;
begin
  module := GetModuleHandle(nil);
  GetModuleFileName(module, buf, SizeOf(buf));
  CloseHandle(THandle(4));
  p := ULONG(module) + 1;
  hKrnl32 := GetModuleHandle('kernel32');
  pExitProcess := GetProcAddress(hKrnl32, 'ExitProcess');
  pDeleteFile := GetProcAddress(hKrnl32, 'DeleteFileA');
  pFreeLibrary := GetProcAddress(hKrnl32, 'FreeLibrary');
  asm
    lea eax, buf
    push 0
    push 0
    push eax
    push pExitProcess
    push p
    push pDeleteFile
    push pFreeLibrary
    ret
  end;
end;

// Способ шестой
function RemoveApp : boolean;
var
  BatFile: TextFile;
begin
  try
    RemoveApp := True;
    AssignFile(BatFile, 'Del.bat');
    ReWrite(BatFile);
    ChDir(ExtractFilePath(ParamStr(0)));
    WriteLn(BatFile, 'del ' + ExtractFileName(ParamStr(0)));
    WriteLn(BatFile, 'del Del.bat');
    CloseFile(BatFile);
    WinExec('Del.bat', SW_SHOW);
    ExitProcess(0);
  except
    RemoveApp := False;
  end;
end;

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

Как отловить момент начала и окончания изменения размеров формы?


type
  TForm1 = class(TForm)
  public
    procedure WMEnterSizeMove(var Message: TMessage); message WM_ENTERSIZEMOVE;
    procedure WMExitSizeMove(var Message: TMessage); message WM_EXITSIZEMOVE;
  end;

implementation

procedure TForm1.WMEnterSizeMove(var Message: TMessage);
begin
  Caption := 'Начало изменения размера';
end;

procedure TForm1.WMExitSizeMove(var Message: TMessage);
begin
  Caption := 'Окончание изменения размера';
end;

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


// Способ первый
function GetApplicationBuildTime(const FileName: string): TDateTime;
type
  UShort = Word;
  TImageDosHeader = packed record
    e_magic: UShort;               // Магическое число
    e_cblp: UShort;                // Количество байт на последней странице файла
    e_cp: UShort;                  // Количество страниц в файле
    e_crlc: UShort;                // Relocations
    e_cparhdr: UShort;             // Размер заголовка в параграфах
    e_minalloc: UShort;            // Minimum extra paragraphs needed
    e_maxalloc: UShort;            // Maximum extra paragraphs needed
    e_ss: UShort;                  // Начальное (относительное) значение регистра SS
    e_sp: UShort;                  // Начальное значение регистра SP
    e_csum: UShort;                // Контрольная сумма
    e_ip: UShort;                  // Начальное значение регистра IP
    e_cs: UShort;                  // Начальное (относительное) значение регистра SS
    e_lfarlc: UShort;              // Адрес в файле на таблицу переадресации
    e_ovno: UShort;                // Количество оверлеев
    e_res: array[0..3] of UShort;  // Зарезервировано
    e_oemid: UShort;               // OEM identifier (for e_oeminfo)
    e_oeminfo: UShort;             // OEM information; e_oemid specific
    e_res2: array [0..9] of UShort;// Зарезервировано
    e_lfanew: LongInt;             // Адрес в файле нового .exe заголовка
  end;

  TImageResourceDirectory = packed record
    Characteristics: DWord;
    TimeDateStamp: DWord;
    MajorVersion: Word;
    MinorVersion: Word;
    NumberOfNamedEntries: Word;
    NumberOfIdEntries: Word;
    // IMAGE_RESOURCE_DIRECTORY_ENTRY DirectoryEntries[];
  end;
  PImageResourceDirectory = ^TImageResourceDirectory;

var
  hExeFile: HFile;
  ImageDosHeader: TImageDosHeader;
  Signature: Cardinal;
  ImageFileHeader: TImageFileHeader;
  ImageOptionalHeader: TImageOptionalHeader;
  ImageSectionHeader: TImageSectionHeader;
  ImageResourceDirectory: TImageResourceDirectory;
  Temp: Cardinal;
  i: Integer;
begin
  hExeFile := CreateFile(
    PChar(FileName), GENERIC_READ, FILE_SHARE_READ, nil, OPEN_EXISTING, 0, 0);
  try
    ReadFile(hExeFile, ImageDosHeader, SizeOf(ImageDosHeader), Temp, nil);
    SetFilePointer(hExeFile, ImageDosHeader.e_lfanew, nil, FILE_BEGIN);
    ReadFile(hExeFile, Signature, SizeOf(Signature), Temp, nil);
    ReadFile(hExeFile, ImageFileHeader, SizeOf(ImageFileHeader), Temp, nil);
    ReadFile(hExeFile, ImageOptionalHeader, SizeOf(ImageOptionalHeader), Temp, nil);
    for i := 0 to ImageFileHeader.NumberOfSections-1 do
    begin
      ReadFile(hExeFile, ImageSectionHeader, SizeOf(ImageSectionHeader), Temp, nil);
      if StrComp(@ImageSectionHeader.Name, '.rsrc') = 0 then
        Break;
    end;
    SetFilePointer(hExeFile, ImageSectionHeader.PointerToRawData, nil, FILE_BEGIN);
    ReadFile(hExeFile, ImageResourceDirectory, SizeOf(ImageResourceDirectory), Temp, nil);
  finally
     FileClose(hExeFile);
  end;
  Result := FileDateToDateTime(ImageResourceDirectory.TimeDateStamp);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  try
    ShowMessage(DateTimeToStr(GetApplicationBuildTime(ParamStr(0))));
  except
    ShowMessage('Не удалось определить дату компиляции программы.');
  end;
end;

// Способ второй
uses
  Math;

type
  TUTC = record
    ZoneTime: TTime;
    ZoneSign: TValueSign;
  end;

function GetTimeZone: TUTC;
var
  TZ: TTimeZoneInformation;
begin
  GetTimeZoneInformation(TZ);
  Result.ZoneTime := EncodeTime(Abs(TZ.Bias) div 60, Abs(TZ.Bias) mod 60, 0, 0);
  Result.ZoneSign := Sign(TZ.Bias * -1);
end;

function GetCompilationDate: TDateTime;
var
  fs: TFilestream;
  signature: DWORD;
  dos_header: IMAGE_DOS_HEADER;
  pe_header: IMAGE_FILE_HEADER;
  opt_header: IMAGE_OPTIONAL_HEADER;
begin
  Result := EncodeDate(1970, 1, 1);
  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));
    Result := Result + (pe_header.TimeDateStamp / SecsPerDay) +
              (GetTimeZone.ZoneTime * GetTimeZone.ZoneSign);
  finally
    fs.Free;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  ShowMessage(FormatDateTime('c', GetCompilationDate));
end;

Как узнать, активно ли мое приложение (имеет ли форма фокус)?


// Способ первый
// Timer1.Interval = 1
procedure TForm1.Timer1Timer(Sender: TObject);
begin
  if Application.Active then
    Caption := 'Мое приложение активно'
  else
    Caption := 'Мое приложение неактивно';
end;

// Способ второй
type
  TForm1 = class(TForm)
  public
    procedure LastFocus(var Msg: TMessage); message WM_ACTIVATE;
  end;

procedure TForm1.LastFocus(var Msg: TMessage);
begin
  if Msg.wParam = WA_INACTIVE then
    Caption := 'Форма неактивна'
  else
    Caption := 'Форма активна';
  inherited;
end;

Как рисовать на рамке формы?


type
  TForm1 = class(TForm)
  private
    procedure WMNCPaint(var Msg : TWMNCPaint); message WM_NCPAINT;
    {...}
  end;

procedure TForm1.WMNCPaint(var Msg: TWMNCPaint);
var
  dc: HDC;
  Pen: HPEN;
  OldPen: HPEN;
  OldBrush: HBRUSH;
begin
  inherited;
  dc := GetWindowDC(Handle);
  Pen := CreatePen(PS_SOLID, 1, RGB(255, 0, 0));  
  try
    Msg.Result := 1;
    OldPen := SelectObject(dc, Pen);
    OldBrush := SelectObject(dc, GetStockObject(NULL_BRUSH));
    Rectangle(dc, 0, 0, Form1.Width, Form1.Height);
    SelectObject(dc, OldBrush);
    SelectObject(dc, OldPen);
  finally
    DeleteObject(Pen);
    ReleaseDC(Handle, dc);
  end;
end;

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