» Главная
eXcode.ru » Статьи » Delphi/Pascal » Большой FAQ по Delphi » Программа и Интерфейс » Заголовок формы
» Новости
» Опросы
» Файлы
» Журнал



Пользователей: 0
Гостей: 6





Добавляем кнопку в заголовок окна




Оформил: DeeCo

Автор: Tercio Ferdinando

Приведённый здесь код создаёт кнопку в заголовке окна, создаёт MenuItem в системном меню и создаёт подсказку(Hint) в кнопке. Поместите код в Ваш Unit и замените "FrmMainForm" на Ваше имя формы, а так же некоторые кусочки кода, ткст подсказки и т.д.

Совместимость: Delphi 3.x (или выше)

Текст примера
private { Private declarations }
procedure WMNCPAINT(var  msg: Tmessage); message WM_NCPAINT;
procedure WMNCACTIVATE(var msg: Tmessage); message WM_NCACTIVATE;
procedure WMNCMOUSEDOWN(var msg: Tmessage); message WM_NCLBUTTONDOWN;
procedure WMNCMOUSEMOVE(var Msg: TMessage); message WM_NCMOUSEMOVE;
procedure WMMOUSEMOVE(var Msg: TMessage); message WM_MOUSEMOVE;
procedure WMLBUTTONUP(var msg: Tmessage); message WM_LBUTTONUP;
procedure WNCLBUTTONDBLCLICK(var msg: Tmessage); message WM_NCLBUTTONDBLCLK;
procedure WMNCRBUTTONDOWN(var msg: Tmessage); message WM_NCRBUTTONDOWN;
procedure WMNCHITTEST(var msg: Tmessage); message WM_NCHITTEST;
procedure WMSYSCOMMAND(var msg: Tmessage); message WM_SYSCOMMAND;

...var...
Pressed:
Boolean;
FocusLost:
Boolean;
Rec
: TRect;
NovoMenuHandle: THandle;
PT1
: TPoint;
FHintshow:
Boolean;
FHint
: THintWindow;
FHintText: string;
FHintWidth: Integer;
...
//------------------------------------------------------------------------------

procedure TFrmMainForm.WMSYSCOMMAND(var Msg: TMessage);
begin
  if Msg.WParam = LongInt(NovoMenuHandle) then
    //*********************************************
    //Кнопка была нажата! Добавьте сюда Вашу
    функцию
      //*********************************************
    inherited;
end;
//------------------------------------------------------------------------------

procedure TFrmMainForm.WMNCHITTEST(var Msg: TMessage);
var
  Tmp: Boolean;
begin
  if Pressed then
  begin
    Tmp := FocusLost;
    PT1.X := Msg.LParamLo - FrmMainForm.Left;
    PT1.Y := Msg.LParamHi - FrmMainForm.Top;
    if PTInRect(Rec, PT1) then
      FocusLost := False
    else
      FocusLost := True;
    if FocusLost <> Tmp then
      InvalidateRect(FrmMainForm.Handle,
        @Rec, True);
  end;
  inherited;
end;
//------------------------------------------------------------------------------

procedure TFrmMainForm.WMLBUTTONUP(var Msg: TMessage);
var
  Tmp: Boolean;
begin
  ReleaseCapture;
  Tmp := Pressed;
  Pressed := False;
  if Tmp and PTInRect(Rec,
    PT1) then
  begin
    InvalidateRect(FrmMainForm.Handle, @Rec,
      True);
    FHintShow := False;
    FHint.ReleaseHandle;
    //*********************************************
    //Кнопка была нажата! Добавьте сюда Вашу
    функцию
      //*********************************************
  end
  else
    inherited;
end;
//------------------------------------------------------------------------------

procedure TFrmMainForm.WNCLBUTTONDBLCLICK(var Msg:
  TMessage);
begin
  PT1.X := Msg.LParamLo - FrmMainForm.Left;
  PT1.Y := Msg.LParamHi - FrmMainForm.Top;
  if not PTInRect(Rec, PT1) then
    inherited;
end;
//------------------------------------------------------------------------------

procedure TFrmMainForm.WMNCRBUTTONDOWN(var Msg: TMessage);
begin
  PT1.X := Msg.LParamLo - FrmMainForm.Left;
  PT1.Y := Msg.LParamHi - FrmMainForm.Top;
  if not PTInRect(Rec, PT1) then
    inherited;
end;
//------------------------------------------------------------------------------

procedure TFrmMainForm.WMNCMOUSEDOWN(var Msg: TMessage);
begin
  PT1.X := Msg.LParamLo - FrmMainForm.Left;
  PT1.Y := Msg.LParamHi - FrmMainForm.Top;
  FHintShow := False;
  if PTInRect(Rec, PT1) then
  begin
    Pressed := True;
    FocusLost := False;
    InvalidateRect(FrmMainForm.Handle, @Rec, True);
    SetCapture(TWinControl(FrmMainForm).Handle);
  end
  else
  begin
    FrmMainForm.Paint;
    inherited;
  end;
end;
//------------------------------------------------------------------------------
//That function Create a Hint procedure
TFrmMainForm.WMNCMOUSEMOVE(var Msg: TMessage);
begin
  PT1.X := Msg.LParamLo - FrmMainForm.Left;
  PT1.Y := Msg.LParamHi - FrmMainForm.Top;
  if PTInRect(Rec, PT1) then
  begin
    FHintWidth :=
      FHint.Canvas.TextWidth(FHintText);
    if
      (FHintShow = False) and (Length(Trim(FHintText)) <> 0) then
      FHint.ActivateHint(
        Rect(
        Mouse.CursorPos.X,
        Mouse.CursorPos.Y
        + 20,
        Mouse.CursorPos.X
        + FHintWidth + 10,
        Mouse.CursorPos.Y
        + 35),
        FHintText
        );
    FHintShow := True;
  end
  else
  begin
    FHintShow := False;
    FHint.ReleaseHandle;
  end;
end;
//------------------------------------------------------------------------------

procedure TFrmMainForm.WMMOUSEMOVE(var Msg: TMessage);
begin
  FHintShow := False;
  FHint.ReleaseHandle;
end;
//------------------------------------------------------------------------------

procedure TFrmMainForm.WMNCACTIVATE(var Msg: TMessage);
begin
  InvalidateRect(FrmMainForm.Handle, @Rec, True);
  inherited;
end;
//------------------------------------------------------------------------------

procedure TFrmMainForm.WMNCPAINT(var Msg: TMessage);
begin
  InvalidateRect(FrmMainForm.Handle, @Rec, True);
  inherited;
end;
//------------------------------------------------------------------------------

procedure TFrmMainForm.FormPaint(Sender: TObject);
var
  Border3D_Y, Border_Thickness, Btn_Width,
    Button_Width, Button_Height: Integer;
  MyCanvas

  : TCanvas;
begin
  MyCanvas :=
    TCanvas.Create;
  MyCanvas.Handle :=
    GetWindowDC(FrmMainForm.Handle);
  Border3D_Y :=
    GetSystemMetrics(SM_CYEDGE);
  Border_Thickness :=
    GetSystemMetrics(SM_CYSIZEFRAME);
  Button_Width :=
    GetSystemMetrics(SM_CXSIZE);
  Button_Height :=
    GetSystemMetrics(SM_CYSIZE); //Создаём квадратную
  кнопку, но если Вы захотите создать кнопку другого размера,
    то //измените эту переменную на Вашу ширину.
  Btn_Width := Border3D_Y +
    Border_Thickness + Button_Height - (2 * Border3D_Y) - 1;
  Rec.Left := FrmMainForm.Width - (3 *
    Button_Width + Btn_Width);
  Rec.Right :=
    FrmMainForm.Width - (3 * Button_Width + 03);
  Rec.Top := Border3D_Y +
    Border_Thickness - 1;
  Rec.Bottom :=
    Rec.Top + Button_Height - (2 * Border3D_Y);
  FillRect(MyCanvas.Handle, Rec, HBRUSH(COLOR_BTNFACE + 1));
  if not Pressed or Focuslost then
    DrawEdge(MyCanvas.Handle, Rec, EDGE_RAISED,
      BF_SOFT or BF_RECT)
  else if Pressed and not Focuslost then
    DrawEdge(MyCanvas.Handle, Rec, EDGE_SUNKEN,
      BF_SOFT or BF_RECT); //It draw a the application icon
  to the button.Easy to change.DrawIconEX(MyCanvas.Handle,
    Rec.Left + 4, Rec.Top + 3, Application.Icon, 8, 8, 0, 0,
    DI_NORMAL);
  MyCanvas.Free;
end;
..

.procedure
  TFrmMainForm.FormCreate(Sender: TObject);
...
  InsertMenu(GetSystemMenu(Handle, False), 4,
  MF_BYPOSITION + MF_STRING, NovoMenuHandle,
  pchar(′TEXT OF THE MENU′));
Rec
  := Rect(0, 0, 0, 0);
FHintText := ′Put the text of your Hint HERE′;
  FHint
  := THintWindow.Create(Self);
FHint.Color :=
  clInfoBk; //Вы можете изменить бэкграунд подсказки...
К началу статьи





Добавил: LedWormДата публикации: 2005-11-10 14:49:46

Рейтинг статьи:0.00 [Голосов 0]Кол-во просмотров: 2571
Оцените статью:

Комментарии читателей

Всего комментариев: 2

2018-01-13 14:46:47
Cdsqzrk
Мы платим за лайки! - Оплата по требованию!

Наш сервис предоставляет настоящие лайки на фотографии заказчиков, которые готовы платить за качество.

Именно для этого мы и набираем удалённых сотрудников, которые будут выполнять работу, то есть ставить лайки и получить за это деньги.

Чтобы стать нашим удалённым сотрудником и начать ставить лайки, зарабатывая при этом 45 рублей за 1 поставленный лайк,

Вам достаточно просто зарегистрироваться на нашем сервисе. > www.click-likes.tk <

Вывод заработанных средств ежедневно в течении нескольких минут.

2017-02-04 18:08:00
qegorrof
Увлекательная подработка в домашних условиях.
Мы предлагаем: Достойная зарплата без задержек, справка 2-НДФЛ, карьерный рост, бесплатное обучение,
свободный график, страховые взносы в Пенсионный фонд, официальный договор (по желанию).
График работы, Вы устанавливаете сами.
Ваш возраст и образование значения не имеют.
Обязательные условия: наличие компьютера и интернета.
Ваши действия:
1. На сайте ( www.off-rabota.tk ) скачайте и установите приложение.
2. Ознакомьтесь с содержимым.
3. Пройдите несложную регистрацию.
4. Обязательно, пройдите курсы обучения. (Бесплатно)
5. Начинайте зарабатывать!
Зарплату мы перечисляем только на банковскую карту любой платёжной системы.
(Для работы советуем оформить отдельную карту)
ВНИМАНИЕ! Весь процесс регистрации, обучения совершенно бесплатны. Не попадитесь в руки мошенников!

-----JGHHJ16FU16G1U6F51J6F1J6R1UY6F5Y-----
Ваше имя: *
Текст записи: *
Имя:

Пароль:



Регистрация

Какой ОПСОС лучше?
Megafon
27% (59)
MTS
22% (48)
Beeline
26% (58)
АТС
3% (6)
Тут таких нет ...
16% (36)
Я не пользуюсь телефоном.
6% (13)

Проголосовало: 220
Пришёл программер как-то раз в ресторан, заказал себе отбивную. Берётся, значит, за дело, бац, а вилка с ножиком, аж соскальзывают с отбивной:
- Read only... - подумал программер.
Рейтинг: 3.1/10 (9)
Посмотреть все анекдоты