скрыть

скрыть

  Форум  

Delphi FAQ - Часто задаваемые вопросы

| Базы данных | Графика и Игры | Интернет и Сети | Компоненты и Классы | Мультимедиа |
| ОС и Железо | Программа и Интерфейс | Рабочий стол | Синтаксис | Технологии | Файловая система |



Google  
 

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



Автор: 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; //Вы можете изменить бэкграунд подсказки...





Copyright © 2004-2016 "Delphi Sources". Delphi World FAQ




Группа ВКонтакте   Ссылка на Twitter   Группа на Facebook