1

Double Click如果发生时如何滚动和滚动Delphi Form Form.Style:=bsSingle？

我已经定义了以下代码：

unit Unit1;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs;

type
  TForm1 = class(TForm)
  private
    { Private declarations }
    OldClientHeight: Integer;
    procedure WMNCLButtonDblClk(var msg: TWMNCLButtonDblClk); message WM_NCLBUTTONDBLCLK;
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.WMNCLButtonDblClk(var msg: TWMNCLButtonDblClk);
var
  Height : integer;
begin
  if (Msg.HitTest = HTCAPTION) then
  Caption := 'Double Click';
   begin
     if (ClientHeight = 0) then
       begin
         for Height := 0 to OldClientHeight do ClientHeight := Height;
         Application.ProcessMessages;
       end
     else
       begin
         OldClientHeight := ClientHeight;
         for Height := OldClientHeight downto 0 do ClientHeight := Height;
         Application.ProcessMessages;
       end;
   end;
end;

end.

如果Form.Style:=bsSizeable代码完美运行。

但是我Form.Style:=bsSingle和我已经实现了它。

所以我尝试了自己的技巧并以其他方式编码如下：

procedure TForm1.WMNCLButtonDblClk(var msg: TWMNCLButtonDblClk);
var
  Height : integer;
begin
  if (Msg.HitTest = HTCAPTION) then
  Caption := 'Double Click';
  Form1.BorderStyle := bsSizeable;
   begin
     if (ClientHeight = 0) then
       begin
         for Height := 0 to OldClientHeight do ClientHeight := Height;
         Application.ProcessMessages;
       end
     else
       begin
         OldClientHeight := ClientHeight;
         for Height := OldClientHeight downto 0 do ClientHeight := Height;
         Application.ProcessMessages;
       end;
   end;
  Form1.BorderStyle := bsSingle;
end;

但我面临以下问题：

  1. 在Rolling Down 滚滚而下ifDoubleBuffered:=true时，Form.Background变为Blue（我的 Windows XP 主题为默认蓝色）然后变为clBtnFace（我的Form.Background:=clBtnFace）。还有一些闪烁。
  2. 在Rolling Up 集结它没有完全卷起的时候，如果我使用我的技巧，一些表单背景是可见的。

请任何人给我解决方案，以便可以使用“bsSingle”表单样式完全上下滚动表单。

4

1 回答 1

5

您可以Repaint在设置表单高度的每次迭代中调用以摆脱背景问题。

 ..
 for Height := OldClientHeight downto 0 do 
 begin
   ClientHeight := Height;
   Repaint;
 end;
 ..

您不必为动画工作切换边框样式。您的代码失败的原因是ClientHeight固定边框窗口的默认情况下永远不会为 0。


在任何情况下，调用Application.ProcessMessages，您都依赖于运行程序的机器的处理能力来获得动画速度。使用 aTTimer可以避免这种情况。一个例子可能是这样的：

  TForm1 = class(TForm)
    ..
  private
    FOldClientHeight: Integer;
    FContracted: Boolean;
  protected
    procedure WMNCLButtonDblClk(var Msg: TWMNCLButtonDblClk);
      message WM_NCLBUTTONDBLCLK;

...

procedure TForm1.FormCreate(Sender: TObject);
begin
  DoubleBuffered := True;
  FOldClientHeight := ClientHeight;
  Timer1.Enabled := False;
  Timer1.Interval := 10;
end;

procedure TForm1.WMNCLButtonDblClk(var Msg: TWMNCLButtonDblClk);
begin
  if Msg.HitTest = HTCAPTION then
    Timer1.Enabled := True
  else
    inherited;
end;

procedure TForm1.Timer1Timer(Sender: TObject);
var
  MinClientHeight: Integer;
begin
  MinClientHeight := GetSystemMetrics(SM_CYMIN) -
      GetSystemMetrics(SM_CYCAPTION) - 2 * GetSystemMetrics(SM_CYFIXEDFRAME);

  if FContracted then begin
    if ClientHeight < FOldClientHeight then
      ClientHeight := ClientHeight + 5
    else begin
      FContracted := False;
      Timer1.Enabled := False;
    end;
  end else begin
    if ClientHeight > MinClientHeight then
      ClientHeight := ClientHeight - 5
    else begin
      FContracted := True;
      Timer1.Enabled := False;
    end;
  end;
end;


关于“完全卷起”，系统似乎很重视“窗口的最小高度”。或响应 fi 之类SetWindowPos的功能对此无济于事。在窗口上设置一个区域（这可能是一种替代方法）会破坏 DWM 的视觉样式，从而使其无法使用。然而，回应似乎有帮助。请注意，不能保证它可以在特定版本的操作系统上运行。我只用 XP 和 W7 测试过，如果你还想用，请看下面：SetWindowPlacementWM_GETMINMAXINFOWM_WINDOWPOSCHANGING

type
  TForm1 = class(TForm)
    ..
  private
    FOldClientHeight: Integer;
    FContracted, FForceCompletelyContracted: Boolean;
  protected
    procedure WMNCLButtonDblClk(var Msg: TWMNCLButtonDblClk);
      message WM_NCLBUTTONDBLCLK;
    procedure WMWindowPosChanging(var Message: TWMWindowPosChanging);
      message WM_WINDOWPOSCHANGING;

...

procedure TForm1.FormCreate(Sender: TObject);
begin
  BorderStyle := bsSingle;
  DoubleBuffered := True;
  FOldClientHeight := ClientHeight;
  Timer1.Enabled := False;
  Timer1.Interval := 10;
end;

procedure TForm1.WMNCLButtonDblClk(var Msg: TWMNCLButtonDblClk);
begin
  if Msg.HitTest = HTCAPTION then
    Timer1.Enabled := True
  else
    inherited;
end;

procedure TForm1.WMWindowPosChanging(var Message: TWMWindowPosChanging);
begin
  inherited;
  if FContracted and ((Message.WindowPos.flags and SWP_NOSIZE) = 0) and
      FForceCompletelyContracted then
    Message.WindowPos.cy := GetSystemMetrics(SM_CYCAPTION) +
         GetSystemMetrics(SM_CYFIXEDFRAME);
end;

procedure TForm1.Timer1Timer(Sender: TObject);
var
  MinClientHeight: Integer;
begin
  if FContracted then begin
    if FForceCompletelyContracted then begin
      FForceCompletelyContracted := False;
      SetWindowPos(Handle, 0, 0, 0, Width, 0, SWP_NOMOVE or SWP_NOZORDER);
      Exit;
    end;
    if ClientHeight < FOldClientHeight then
      ClientHeight := ClientHeight + 5
    else begin
      FContracted := False;
      Timer1.Enabled := False;
    end;
  end else begin
    MinClientHeight := GetSystemMetrics(SM_CYMIN) -
        GetSystemMetrics(SM_CYCAPTION) - 2 * GetSystemMetrics(SM_CYFIXEDFRAME);
    if ClientHeight > MinClientHeight then
      ClientHeight := ClientHeight - 5
    else begin
      FContracted := True;
      Timer1.Enabled := False;
      FForceCompletelyContracted := True;
      SetWindowPos(Handle, 0, 0, 0, Width, 0, SWP_NOMOVE or SWP_NOZORDER);
    end;
  end;
end;
于 2013-09-02T20:48:04.153 回答