Форум программистов [Powered by Invision Power Board]

Код
unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls;

type
  TForm1 = class(TForm)
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;
  g_hHook: HHOOK;
  g_oldProc: Pointer = nil;
  g_bChecked: Boolean = False;
  g_cb: TCheckBox;
  g_szCbCaption: string = '';

const
  IDC_CHECKBOX = 1000;

implementation

{$R *.dfm}

// узнаём ширину текста для контекста (HDC) определённого окна (hWnd)
function GetTextWidth(hWnd: HWND; const szCaption: string): Integer;
var
  Res: TSize;
begin
  ZeroMemory(@Res, SizeOf(Res));
  GetTextExtentPoint32(GetWindowDC(hWnd), PChar(szCaption), Length(szCaption), Res);
  Result := Res.cx;
end;

function MyMessageBox(hWnd: HWND; const szText, szCaption, szCheckBoxCaption: string; uType: UINT): Integer;
begin
  g_szCbCaption := szCheckBoxCaption;
  Result := MessageBox(hWnd, PChar(szText), PChar(szCaption), uType);
end;

procedure CreateCheckBox(hWndOwner: HWND);
begin
  g_cb := TCheckBox.Create(Application);
  with g_cb do
    begin
      ParentWindow := hWndOwner;
      g_cb.Caption := g_szCbCaption;
      Checked := True;
      g_cb.Width := GetTextWidth(g_cb.Handle, g_szCbCaption);
      SetWindowLong(Handle, GWL_ID, IDC_CHECKBOX);
    end;
end;

procedure UnInstallHook(m_gHook: HHOOK);
begin
    // Uninstall the hook
    UnhookWindowsHookEx(m_gHook);
end;

function SetOut: Boolean;
begin
  g_cb.Checked := not g_cb.Checked;
end;

function HookWndProc(hWnd: HWND; uMsg, wParam, lParam: Integer): Integer; stdcall;
var
  nRc: Integer;
begin
  // дадим ОС обработать основные операции
  nRc := CallWindowProc(g_oldProc, hWnd, uMsg, wParam, lParam);

  // если диалог хочет загрузиться, то...
  if (uMsg = WM_INITDIALOG) then
      begin
      // создаём на нём кнопку
      CreateCheckBox(hWnd);
    end;

  // если кликнули по checkbox-у
  // на это указывает его nID
    if (uMsg = WM_COMMAND) and (wParam = IDC_CHECKBOX) then
    SetOut; // обрабатываем нажатие на checkbox

  // если диалог уничтожается, то...
    if (uMsg = WM_NCDESTROY) then
    begin
        UnInstallHook(g_hHook);
      FreeAndNil(g_cb);
    end;

  Result := nRc;
end;

// функция ловушки нашего приложения
function SetHook(nCode, wParam, lParam: Integer): Integer; stdcall;
var
  M: TCWPStruct;
begin
  if (nCode = HC_ACTION) then
    begin
      M := TCWPStruct(Pointer(lParam)^);

      // если нам пришло сообщение, что сейчас будет создан checkbox, то ....
      if M.message = WM_INITDIALOG then
        g_oldProc := Pointer(SetWindowLong(M.hwnd, GWL_WNDPROC, Integer(@HookWndProc)));
    end;

  Result := CallNextHookEx(g_hHook, nCode, wParam, lParam);
end;

// устанавливаем ловушку на все сообщения, которые
// предназначаются оконной процедуре
// мы будем их обрабатывать перед оконной процедурой
function InstallHook: HHOOK;
begin
    g_hHook := SetWindowsHookEx(WH_CALLWNDPROC,
                              @SetHook, // процедура обработки ловушки
                              0,
                              GetCurrentThreadId()); // ассоциируем ловушку с текущим (потоком нешего окна) потоком
  Result := g_hHook;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  InstallHook;
  MyMessageBox(Handle, 'Исходные данные будут перезаписаны!', 'Продолжить?', 'Больше не предупреждать меня', MB_ICONQUESTION or MB_YESNO)
end;

end.