Свернуть развернуть форму

[user6745]

Имеется вот такая программа (исходный код программы прикладываю).

Как наладить исправную работу кнопки свернуть? Чтобы все работало как стандартная кнопка окон windows свернуть.

Отличия от стандартного поведения:

1. при сворачивании и разворачивании на панели исчезает иконка программы и затем появляется.

2. для того чтобы свернуть или развернуть программу на панели задач нужно нажать 2 раза на иконку этой программы. если открыть любую стандартную программу windows, например калькулятор, то для его сворачивания и разворачивания достаточно на панели задач нажать 1 раз на иконку программы.

3. если запустить программу, а затем много раз нажимать на иконку программы на панели задач, то программа начинает исчезать - она все время отображается на экране, но нижняя и правая грани формы смещаются в лево и вверх. форма уменьшается почему-то! (этот баг я вижу в windows 10, пользователи windows 7 говорят то там такого нет, но я лично не проверял.) но думаю что это поправимо, потому что в стандартных программах windows 10 такого нет, значит это можно исправить, вопрос только как исправить?

4. когда программа развернута, при нажатии на иконку программы на панели задач она не сворачивается.

Как это исправить? Подскажите пожалуйста!

[iskander]

Как вариант

Код: Выделить всё

unit Unit1;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, Forms, Controls, Graphics, Dialogs, ExtCtrls, StdCtrls, Windows;

type

  { TForm1 }

  TForm1 = class(TForm)
    Button1: TButton;
    Image1: TImage;
    procedure Button1Click(Sender: TObject);
    procedure FormActivate(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure Image1Click(Sender: TObject);
    procedure TrayIcon1Click(Sender: TObject);
  private

  public

  end;

var
  Form1: TForm1;

implementation

{$R *.lfm}

{ TForm1 }

procedure TForm1.Image1Click(Sender: TObject);
begin
  Application.Minimize;
  //Application.MainFormOnTaskBar := false;
  //ShowWindow(Application.Handle, SW_SHOW);
end;

procedure TForm1.TrayIcon1Click(Sender: TObject);
begin
  //ShowWindow(Application.Handle, SW_HIDE);
  //Application.MainFormOnTaskBar := True;
  //Application.MainForm.Show;
end;

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

procedure TForm1.FormActivate(Sender: TObject);
begin
  //SetWindowLongPtr(Handle, GWL_STYLE, GetWindowLongPtr(Handle, GWL_STYLE) and not WS_DLGFRAME);
  //MoveWindow(Handle, Left, Top, Width-1, Height, True);
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  Caption:='';
  BorderIcons:=[];
  BorderStyle:=bsSingle;

  //Application.OnRestore := @TrayIcon1Click;
  //Application.OnActivate := @FormActivate;
  SetWindowLongPtr(Handle, GWL_STYLE, GetWindowLongPtr(Handle, GWL_STYLE) and not WS_DLGFRAME);
end;

end.

[user6745]

iskander Спасибо большое! Все отлично работает!

Добавлено спустя 1 час 13 минут 55 секунд:
iskander Заметил один такой момент вылезает после применения этого кода.

Разместил на форме Image шириной равный форме. В обычной ситуации если задать одинаковую ширину для картинки (у картинки left равно 0) и для формы, то отступа картинки от края нет. А после применения этого кода он появляется. Как это исправить?

[iskander]

Можно так попробовать

Код: Выделить всё

unit Unit1;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, Forms, Controls, Graphics, Dialogs, ExtCtrls, StdCtrls, Windows;

type

  { TForm1 }

  TForm1 = class(TForm)
    Button1: TButton;
    Image1: TImage;
    Image2: TImage;
    procedure Button1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormShow(Sender: TObject);
    procedure Image1Click(Sender: TObject);
  private
    FShowing: Boolean;
  public

  end;

var
  Form1: TForm1;

implementation

{$R *.lfm}

{ TForm1 }

procedure TForm1.Image1Click(Sender: TObject);
begin
  Application.Minimize;
end;

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

procedure TForm1.FormCreate(Sender: TObject);
begin
  Caption:='';
  BorderIcons:=[];
  BorderStyle:= bsSingle;
  SetWindowLongPtr(Handle, GWL_STYLE, GetWindowLongPtr(Handle, GWL_STYLE) and not WS_DLGFRAME);
end;

procedure TForm1.FormShow(Sender: TObject);
begin
  if FShowing then
    exit;
  FShowing := True;
  Width := Width - 1;
  Width := Width + 1;
end;

end.

[user6745]

iskander Спасибо.
Но этот момент появляется если добавляю возможность перетаскивать форму за картинку MouseMove.

Код: Выделить всё

unit Unit1;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, Forms, Controls, Graphics, Dialogs, ExtCtrls, StdCtrls, Windows;

type

  { TForm1 }

  TForm1 = class(TForm)
    Button1: TButton;
    Image1: TImage;
    Image2: TImage;
    procedure Button1Click(Sender: TObject);
    procedure FormActivate(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormShow(Sender: TObject);
    procedure Image1Click(Sender: TObject);
    procedure Image2MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer
      );
    procedure TrayIcon1Click(Sender: TObject);
  private
    FShowing: Boolean;
  public

  end;

var
  Form1: TForm1;
  XX,YY:integer;

implementation

{$R *.lfm}

{ TForm1 }

procedure TForm1.Image1Click(Sender: TObject);
begin
  Application.Minimize;
end;

procedure TForm1.Image2MouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
begin
  if Shift=[ssLeft] then
 begin
   Left:=Left+(X-XX);
   Top:=Top+(Y-YY);
 end else
 begin
   XX:=X;
   YY:=Y;
 end;
end;

procedure TForm1.TrayIcon1Click(Sender: TObject);
begin

end;

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

procedure TForm1.FormActivate(Sender: TObject);
begin

end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  Caption:='';
  BorderIcons:=[];
  BorderStyle:= bsSingle;
  SetWindowLongPtr(Handle, GWL_STYLE, GetWindowLongPtr(Handle, GWL_STYLE) and not WS_DLGFRAME);
end;

procedure TForm1.FormShow(Sender: TObject);
begin
  if FShowing then
    exit;
  FShowing := True;
  Width := Width - 4;
  Width := Width + 0;
end;

end.

Заметил еще один момент: при перетаскивании формы за картинку прибавляется высота формы снизу.

В обычном варианте форму за картинку можно перетаскивать без этих странностей. Но когда добавляю код который убирает шапку и позволяет нормально сворачивать и разворачивать форму, то появляются вот такие странные эффекты. Почему, непонятно.

Как это можно исправить? Подскажите пожалуйста.

Добавлено спустя 48 минут 9 секунд:
высоту и ширину формы задал вот так, и теперь не увеличивается

Код: Выделить всё

procedure TForm1.Image2MouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
begin
  if Shift=[ssLeft] then
 begin
   Left:=Left+(X-XX);
   Top:=Top+(Y-YY);
 end else
 begin
   XX:=X;
   YY:=Y;
 end;

  //задаем высоту и ширину формы чтобы не увеличивалась
  Form1.Height := 300;
  Form1.Width := 400;

end;  

С шириной картинки чтобы не мучиться, просто увеличил ширину картинки на 4, и теперь все так работает.

Вопрос с глюками по ширине и высоте формы решен с помощью костылей.
Если есть более удобный и правильный способ решить этот вопрос было бы хорошо.

Но в принципе и так все нормально работает теперь. )

[iskander]

Если просто установить BorderStyle := bsNone то глюков не наблюдается.

Код: Выделить всё

unit Unit1;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, Forms, Controls, Graphics, Dialogs, ExtCtrls, StdCtrls, Windows;

type

  { TForm1 }

  TForm1 = class(TForm)
    Button1: TButton;
    Image1: TImage;
    Image2: TImage;
    procedure Button1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure Image1Click(Sender: TObject);
    procedure Image2MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
  private
    FMovX,
    FMovY: Integer;
  public

  end;

var
  Form1: TForm1;

implementation

{$R *.lfm}

{ TForm1 }

procedure TForm1.Image1Click(Sender: TObject);
begin
  Application.Minimize;
end;

procedure TForm1.Image2MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
begin
  if Shift=[ssLeft] then begin
     Left := Left + X- FMovX;
     Top := Top + Y - FMovY;
  end else begin
     FMovX := X;
     FMovY := Y;
  end;
end;

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

procedure TForm1.FormCreate(Sender: TObject);
begin
  Caption := '';
  //BorderIcons := [];
  //BorderStyle:=bsSingle;
  BorderStyle := bsNone;
  //SetWindowLongPtr(Handle, GWL_STYLE, GetWindowLongPtr(Handle, GWL_STYLE) and not WS_DLGFRAME);
end;

end.

[user6745]

iskander, тогда исчезает рамка. Оставим все как есть. Все в таком варианте с костылями нормально работает. Вполне сойдет.

Спасибо большое за помощь! Я сам долго мучился с тем как сделать чтобы нормально сворачивалось и разворачивалось! Вы очень помогли!

[iskander]

тогда исчезает рамка

А если бросить на форму картинку рамки?

[user6745]

А если бросить на форму картинку рамки?

В принципе тоже вариант рисованная рамка с помощью TImage. Спасибо.