Недавно добавленные исходники

•  3D Designer  134

•  Sik Screen Capture  109

•  Patch Maker  92

•  Айболит (remote control)  113

•  ListBox Drag & Drop  85

•  Доска для игры Реверси  1 558

•  Графические эффекты  100

•  Рисование по маске  76

•  Перетаскивание изображений  79

•  Canvas Drawing  82

•  Рисование Луны  152

•  Поворот изображения  65

•  Рисование стержней  56

•  Paint on Shape  52

•  Генератор кроссвордов  60

•  Головоломка Paletto  75

•  Теорема Монжа об окружностях  113

•  Пазл Numbrix  56

•  Заборы и коммивояжеры  87

•  Игра HIP  66

•  Игра Go (Го)  51

•  Симулятор лифта  55

•  Программа укладки плитки  56

•  Генератор лабиринта  97

•  Проверка числового ввода  45

•  HEX View  101

•  Физический маятник  102

•  Задача коммивояжера  129

•  Автомобильная пробка  52

•  Квадратные сетки из слов  46

 
скрыть


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

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



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



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




Похожие по теме исходники

Посторонние окна WinAPI




Copyright © 2004-2021 "Delphi Sources" by BrokenByte Software. Delphi World FAQ

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