View Issue Details

IDProjectCategoryView StatusLast Update
0016782LazarusLCLpublic2010-06-28 20:30
ReporterEugen BolzAssigned ToPaul Ishenin 
PrioritynormalSeverityblockReproducibilityalways
Status closedResolutionfixed 
PlatformOSWindows 7OS Version
Product Version0.9.29 (SVN)Product Build 
Target VersionFixed in Version0.9.29 (SVN) 
Summary0016782: Anchordock: Draging a Window is slow on Windows Vista/7
DescriptionHey,

if you drag a window, it is very slow, it only happens when aero is on...

Mailinglist: http://lists.lazarus.freepascal.org/pipermail/lazarus/2010-June/053558.html

I've already searched for a solution: http://qc.embarcadero.com/wc/qcmain.aspx?d=48672 this may helps, but I couldn't implement it, because the OnStartDock-Event don't get called :( ...
 
TagsNo tags attached.
Fixed in Revision26309
LazTarget-
WidgetsetWin32/Win64
Attached Files
  • dragdockalphablend.pas (1,295 bytes)
    {
      Windows Aero Solution for Docking-Focus-Rect
      LCL-Implementation of http://qc.embarcadero.com/wc/qcmain.aspx?d=48672
    }
    
    unit DragDockAlphaBlend;
    
    {$mode objfpc}
    
    interface
    
    uses
      Classes, SysUtils, Controls, Forms, Graphics;
    
    type
      { TDragDockObjectEx_AlphaBlend }
    
      TDragDockObjectEx_AlphaBlend = class(TDragDockObjectEx)
      private
        FForm: TForm;
      protected
        procedure ShowDockImage; override;
        procedure MoveDockImage; override;
      public
        procedure AfterConstruction; override;
        procedure BeforeDestruction; override;
      end;
    
    implementation
    
    procedure TDragDockObjectEx_AlphaBlend.ShowDockImage;
    begin
       FForm.BoundsRect := DockRect;
       if not FForm.Visible then
          FForm.Show;
    end;
    
    procedure TDragDockObjectEx_AlphaBlend.MoveDockImage;
    begin
      FForm.BoundsRect := DockRect;
    end;
    
    procedure TDragDockObjectEx_AlphaBlend.AfterConstruction;
    begin
      inherited;
      FForm := TForm.Create(nil);
      FForm.BorderStyle := bsNone;
      FForm.AlphaBlend := True;
      FForm.AlphaBlendValue := 100;
      FForm.Color := RGBToColor(96, 111, 151);
      FForm.FormStyle := fsStayOnTop;
    
      EraseDockRect:= Rect(0,0,0,0);
    end;
    
    procedure TDragDockObjectEx_AlphaBlend.BeforeDestruction;
    begin
      inherited;
      FForm.Free;
    end;
    
    
    end.
    
    
    dragdockalphablend.pas (1,295 bytes)

Activities

José Mejuto

2010-06-24 00:07

reporter   ~0038777

The problem is that direct writes to screen (desktop screen) are now disabling composition, paint and reenable composition, which renders to a brutal CPU power needed.

There are 2 basic solutions:

1) Use a window with alpha transparency to simulate the rect. Selecting zones of same color as window could be a visual problem.

2) Using the same technique as Microsoft MFC. Relevant code can be found in the last message of this thread: http://www.gamedev.net/community/forums/topic.asp?topic_id=559680 It requires a bit of CPU more than (1).

2010-06-25 16:27

 

dragdockalphablend.pas (1,295 bytes)
{
  Windows Aero Solution for Docking-Focus-Rect
  LCL-Implementation of http://qc.embarcadero.com/wc/qcmain.aspx?d=48672
}

unit DragDockAlphaBlend;

{$mode objfpc}

interface

uses
  Classes, SysUtils, Controls, Forms, Graphics;

type
  { TDragDockObjectEx_AlphaBlend }

  TDragDockObjectEx_AlphaBlend = class(TDragDockObjectEx)
  private
    FForm: TForm;
  protected
    procedure ShowDockImage; override;
    procedure MoveDockImage; override;
  public
    procedure AfterConstruction; override;
    procedure BeforeDestruction; override;
  end;

implementation

procedure TDragDockObjectEx_AlphaBlend.ShowDockImage;
begin
   FForm.BoundsRect := DockRect;
   if not FForm.Visible then
      FForm.Show;
end;

procedure TDragDockObjectEx_AlphaBlend.MoveDockImage;
begin
  FForm.BoundsRect := DockRect;
end;

procedure TDragDockObjectEx_AlphaBlend.AfterConstruction;
begin
  inherited;
  FForm := TForm.Create(nil);
  FForm.BorderStyle := bsNone;
  FForm.AlphaBlend := True;
  FForm.AlphaBlendValue := 100;
  FForm.Color := RGBToColor(96, 111, 151);
  FForm.FormStyle := fsStayOnTop;

  EraseDockRect:= Rect(0,0,0,0);
end;

procedure TDragDockObjectEx_AlphaBlend.BeforeDestruction;
begin
  inherited;
  FForm.Free;
end;


end.

dragdockalphablend.pas (1,295 bytes)

Eugen Bolz

2010-06-25 16:31

reporter   ~0038807

Hey :)

I have implemented Solution 1).

Using this Patch for AnchorDock: 0016789 and the Unit: dragdockalphablend.pas.

Now we just have to create a Custom TDragDockObject with the TForm.OnStartDock-Event.

Example:
procedure TForm1.FormStartDock(Sender: TObject;
  var DragObject: TDragDockObject);
begin
   DragObject := TDragDockObjectEx_AlphaBlend.Create(TControl(Sender));
   // TForm(Sender) would create an exception
end;

Now I can dock all without have a stupid slow focus rect :)

Paul Ishenin

2010-06-28 10:23

manager   ~0038849

Please test and close if ok.

Eugen Bolz

2010-06-28 20:30

reporter   ~0038857

It is working now, thanks :)

0016789 can be closed now too :)

Issue History

Date Modified Username Field Change
2010-06-23 20:35 Eugen Bolz New Issue
2010-06-23 20:35 Eugen Bolz Widgetset => Win32/Win64
2010-06-24 00:07 José Mejuto Note Added: 0038777
2010-06-25 16:27 Eugen Bolz File Added: dragdockalphablend.pas
2010-06-25 16:31 Eugen Bolz Note Added: 0038807
2010-06-27 14:17 Mattias Gaertner Status new => assigned
2010-06-27 14:17 Mattias Gaertner Assigned To => Mattias Gaertner
2010-06-27 14:20 Mattias Gaertner Assigned To Mattias Gaertner => Paul Ishenin
2010-06-28 10:23 Paul Ishenin Fixed in Revision => 26309
2010-06-28 10:23 Paul Ishenin LazTarget => -
2010-06-28 10:23 Paul Ishenin Status assigned => resolved
2010-06-28 10:23 Paul Ishenin Fixed in Version => 0.9.29 (SVN)
2010-06-28 10:23 Paul Ishenin Resolution open => fixed
2010-06-28 10:23 Paul Ishenin Note Added: 0038849
2010-06-28 20:30 Eugen Bolz Status resolved => closed
2010-06-28 20:30 Eugen Bolz Note Added: 0038857