delphi – 性能问题重新调整表单大小上的大量组件

前端之家收集整理的这篇文章主要介绍了delphi – 性能问题重新调整表单大小上的大量组件前端之家小编觉得挺不错的,现在分享给大家,也给大家做个参考。
我觉得我的失败到目前为止在于搜索术语,因为这方面的信息必须很常见.在调整表单时,基本上我正在寻找常用的解决方案和最佳实践.

我有一个基于TScrollBox的组件的表单. ScrollBox包含在运行时动态添加的行.它们基本上是一个子组件.每个人都有左边的图像和右边的备忘录.基于图像的宽高比设置高度.在滚动框的大小调整后,循环设置触发行自身内部调整大小的行的宽度.如果高度已经改变,循环也会设置相对的顶部位置.

屏幕截图:

大约16行执行正常.我的目标是更接近32排,这是非常波动,可以钉在100%使用的核心.

我努力了:

>添加了一个支票,以防止在前一个尚未完成时启动新的调整大小.它回答了它是否发生,有时它.
>我试图阻止它每30ms更多地调整大小,这将允许每秒30帧的绘图.混合结果.
>将行基​​础组件从TPanel更改为TWinControl.不知道使用小组是否有性能损失,但它是一种老习惯.
>有和没有双缓冲.

我想允许在调整大小期间进行行调整大小,作为预览图像的大小.这消除了在一些应用中是可接受的损失的一个明显的解决方案.

现在,该行内部的调整大小代码是完全动态的,并且基于每个图像的维度.我打算尝试的下一件事是基于集合中最大的图像基本指定纵横比,最大宽度/高度.这应该减少每行的数学量.但是,似乎问题更多的是调整大小事件和循环本身?

组件的完整单元代码

unit rPBSSVIEW;

interface

uses
  Classes,Controls,Forms,ExtCtrls,StdCtrls,Graphics,SysUtils,rPBSSROW,Windows,Messages;

type
  TPBSSView = class(TScrollBox)
  private    
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure ResizeRows(Sender: TObject);
    procedure AddRow(FileName: String);
    procedure FillRow(Row: Integer; ImageStream: TMemoryStream);
  end;

var
  PBSSrow: Array of TPBSSRow;
  Resizingn: Boolean;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('Standard',[TScrollBox]);
end;

procedure TPBSSView.AddRow(FileName: String);
begin
  SetLength(PBSSrow,(Length(PBSSrow) + 1));
  PBSSrow[Length(PBSSrow)-1] := TPBSSRow.create(self);
  With PBSSrow[Length(PBSSrow)-1] do
  begin
    Left := 2;
    if (Length(PBSSrow)-1) = 0 then Top := 2 else Top := ((PBSSRow[Length(PBSSRow) - 2].Top + PBSSRow[Length(PBSSRow) - 2].Height) + 2);
    Width := (inherited ClientWidth - 4);
    Visible := True;
    Parent := Self;
    PanelLeft.Caption := FileName;
  end;
end;

procedure TPBSSView.FillRow(Row: Integer; ImageStream: TMemoryStream);
begin
  PBSSRow[Row].LoadImageFromStream(ImageStream);
end;

procedure TPBSSView.ResizeRows(Sender: TObject);
var
  I,X: Integer;
begin
  if Resizingn then exit
  else
  begin
      Resizingn := True;
      HorzScrollBar.Visible := False;
      X := (inherited ClientWidth - 4);
      if Length(PBSSrow) > 0 then
      for I := 0 to Length(PBSSrow) - 1 do
      Begin
        PBSSRow[I].Width := X; //Set Width
        if not (I = 0) then      //Move all next ones down.
          begin
            PBSSRow[I].Top := (PBSSRow[(I - 1)].Top + PBSSRow[(I - 1)].Height) + 2;
          end;
        Application.ProcessMessages;
      End;
    HorzScrollBar.Visible := True;
    Resizingn := False;
  end;
end;

constructor TPBSSView.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  OnResize := ResizeRows;
  DoubleBuffered := True;
  VertScrollBar.Tracking := True;
  Resizingn := False;
end;

destructor TPBSSView.Destroy;
begin
  inherited;
end;

end.

行号:

unit rPBSSROW;

interface

uses
  Classes,pngimage,SysUtils;

type
  TPBSSRow = class(TWinControl)
  private
    FImage: TImage;
    FPanel: TPanel;
    FMemo: TMemo;
    FPanelLeft: TPanel;
    FPanelRight: TPanel;
    FImageWidth: Integer;
    FImageHeight: Integer;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure MyPanelResize(Sender: TObject);
    procedure LeftPanelResize(Sender: TObject);
  published
    procedure LoadImageFromStream(ImageStream: TMemoryStream);
    property Image: TImage read FImage;
    property Panel: TPanel read FPanel;
    property PanelLeft: TPanel read FPanelLeft;
    property PanelRight: TPanel read FPanelRight;
  end;

procedure Register;    

implementation

procedure Register;
begin
  RegisterComponents('Standard',[TWinControl]);
end;

procedure TPBSSRow.MyPanelResize(Sender: TObject);
begin
  if (Width - 466) <= FImageWidth then FPanelLeft.Width := (Width - 466)
else FPanelLeft.Width := FImageWidth;
  FPanelRight.Width := (Width - FPanelLeft.Width);
end;

procedure TPBSSRow.LeftPanelResize(Sender: TObject);
var
  AspectRatio: Extended;
begin
  FPanelRight.Left := (FPanelLeft.Width);
  //Enforce Info Minimum Height or set Height
  if FImageHeight > 0 then  AspectRatio := (FImageHeight/FImageWidth) else
  AspectRatio := 0.4;
  if (Round(AspectRatio * FPanelLeft.Width)) >= 212 then
  begin
    Height := (Round(AspectRatio * FPanelLeft.Width));
    FPanelLeft.Height := Height;
    FPanelRight.Height := Height;
  end
  else
  begin
    Height :=212;
    FPanelLeft.Height := Height;
    FPanelRight.Height := Height;
  end;
  if Fimage.Height >= FImageHeight then FImage.Stretch := False else Fimage.Stretch := True;
  if Fimage.Width >= FImageWidth then FImage.Stretch := False else Fimage.Stretch := True;
end;

procedure TPBSSRow.LoadImageFromStream(ImageStream: TMemoryStream);
var
  P: TPNGImage;
  n: Integer;
begin
  P := TPNGImage.Create;
  ImageStream.Position := 0;
  P.LoadFromStream(ImageStream);
  FImage.Picture.Assign(P);
  FImageWidth := P.Width;
  FImageHeight := P.Height;
end;

constructor TPBSSRow.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
    BevelInner := bvNone;
    BevelOuter := bvNone;
    BevelKind :=  bkNone;
    Color := clWhite;
    OnResize := MyPanelResize;
    DoubleBuffered := True;
  //Left Panel for Image
  FPanelLeft := TPanel.Create(Self);
  with FPanelLeft do
  begin
    SetSubComponent(true);
    Align := alLeft;
    Parent := Self;
    //SetBounds(0,100,100);
    ParentBackground := False;
    Color := clBlack;
    Font.Color := clLtGray;
    Constraints.MinWidth := 300;
    BevelInner := bvNone;
    BevelOuter := bvNone;
    BevelKind :=  bkNone;
    BorderStyle := bsNone;
    OnResize := LeftPanelResize;
  end;
  //Image for left panel
  FImage := TImage.Create(Self);
  FImage.SetSubComponent(true);
  FImage.Align := alClient;
  FImage.Parent := FPanelLeft;
  FImage.Center := True;
  FImage.Stretch := True;
  FImage.Proportional := True;
  //Right Panel for Info
  FPanelRight := TPanel.Create(Self);
  with FPanelRight do
  begin
    SetSubComponent(true);
    Parent := Self;
    Padding.SetBounds(2,5,2);
    BevelInner := bvNone;
    BevelOuter := bvNone;
    BevelKind :=  bkNone;
    BorderStyle := bsNone;
    Color := clLtGray;
  end;

  //Create Memo in Right Panels
  FMemo := TMemo.create(self);
  with FMemo do
  begin
    SetSubComponent(true);
    Parent := FPanelRight;
    Align := alClient;
    BevelOuter := bvNone;
    BevelInner := bvNone;
    BorderStyle := bsNone;
    Color := clLtGray;
  end;

end;

destructor TPBSSRow.Destroy;
begin
  inherited;
end;

end.

解决方法

几个提示

> TWinControl已经是一个容器,你不需要另外一个面板来添加控件
>您不需要TImage组件来查看图形,也可以使用TPaintBox,或者在下面的示例控件中,TCustomControl,
>由于您的所有其他面板都不可识别(边框和斜面被禁用),完全松开它们,并将TMemo直接放在行控件上,
> SetSubComponent仅用于设计时间的使用.你不需要它也不是注册程序.
将全局行数组放在类定义中,否则多个TPBSSView控件将使用相同的数组!
> TWinControl已经跟踪了它的所有子控件,所以你不需要数组,看我下面的例子,
>使用Align属性来保存您手动重新对齐,
>如果备忘录控件仅用于显示文本,则将其删除并自行绘制文本.

尝试这个开始:

unit PBSSView;

interface

uses
  Windows,Messages,Classes,PngImage;

type
  TPBSSRow = class(TCustomControl)
  private
    FGraphic: TPngImage;
    FStrings: TStringList;
    function ImageHeight: Integer; overload;
    function ImageHeight(ControlWidth: Integer): Integer; overload;
    function ImageWidth: Integer; overload;
    function ImageWidth(ControlWidth: Integer): Integer; overload;
    procedure WMEraseBkgnd(var Message: TWmEraseBkgnd); message WM_ERASEBKGND;
    procedure WMWindowPosChanging(var Message: TWMWindowPosChanging);
      message WM_WINDOWPOSCHANGING;
  protected
    procedure Paint; override;
    procedure RequestAlign; override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure LoadImageFromStream(Stream: TMemoryStream);
    property Strings: TStringList read FStrings;
  end;

  TPBSSView = class(TScrollBox)
  private
    function GetRow(Index: Integer): TPBSSRow;
    procedure WMEnterSizeMove(var Message: TMessage); message WM_ENTERSIZEMOVE;
    procedure WMEraseBkgnd(var Message: TWmEraseBkgnd); message WM_ERASEBKGND;
    procedure WMExitSizeMove(var Message: TMessage); message WM_EXITSIZEMOVE;
  protected
    procedure PaintWindow(DC: HDC); override;
  public
    constructor Create(AOwner: TComponent); override;
    procedure AddRow(const FileName: TFileName);
    procedure FillRow(Index: Integer; ImageStream: TMemoryStream);
    property Rows[Index: Integer]: TPBSSRow read GetRow;
  end;

implementation

{ TPBSSRow }

constructor TPBSSRow.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  Width := 300;
  Height := 50;
  FStrings := TStringList.Create;
end;

destructor TPBSSRow.Destroy;
begin
  FStrings.Free;
  FGraphic.Free;
  inherited Destroy;
end;

function TPBSSRow.ImageHeight: Integer;
begin
  Result := ImageHeight(Width);
end;

function TPBSSRow.ImageHeight(ControlWidth: Integer): Integer;
begin
  if (FGraphic <> nil) and not FGraphic.Empty then
    Result := Round(ImageWidth(ControlWidth) * FGraphic.Height / FGraphic.Width)
  else
    Result := Height;
end;

function TPBSSRow.ImageWidth: Integer;
begin
  Result := ImageWidth(Width);
end;

function TPBSSRow.ImageWidth(ControlWidth: Integer): Integer;
begin
  Result := ControlWidth div 2;
end;

procedure TPBSSRow.LoadImageFromStream(Stream: TMemoryStream);
begin
  FGraphic.Free;
  FGraphic := TPngImage.Create;
  Stream.Position := 0;
  FGraphic.LoadFromStream(Stream);
  Height := ImageHeight + Padding.Bottom;
end;

procedure TPBSSRow.Paint;
var
  R: TRect;
begin
  Canvas.StretchDraw(Rect(0,ImageWidth,ImageHeight),FGraphic);
  SetRect(R,Width,ImageHeight);
  Canvas.FillRect(R);
  Inc(R.Left,10);
  DrawText(Canvas.Handle,FStrings.Text,-1,R,DT_EDITCONTROL or
    DT_END_ELLIPSIS or DT_NOFULLWIDTHCHARBREAK or DT_NOPREFIX or DT_WORDBREAK);
  Canvas.FillRect(Rect(0,ImageHeight,Height));
end;

procedure TPBSSRow.RequestAlign;
begin
  {eat inherited}
end;

procedure TPBSSRow.WMEraseBkgnd(var Message: TWmEraseBkgnd);
begin
  Message.Result := 1;
end;

procedure TPBSSRow.WMWindowPosChanging(var Message: TWMWindowPosChanging);
begin
  inherited;
  if (FGraphic <> nil) and not FGraphic.Empty then
    Message.WindowPos.cy := ImageHeight(Message.WindowPos.cx) + Padding.Bottom;
end;

{ TPBSSView }

procedure TPBSSView.AddRow(const FileName: TFileName);
var
  Row: TPBSSRow;
begin
  Row := TPBSSRow.Create(Self);
  Row.Align := alTop;
  Row.Padding.Bottom := 2;
  Row.Parent := Self;
end;

constructor TPBSSView.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  VertScrollBar.Tracking := True;
end;

procedure TPBSSView.FillRow(Index: Integer; ImageStream: TMemoryStream);
begin
  Rows[Index].LoadImageFromStream(ImageStream);
end;

function TPBSSView.GetRow(Index: Integer): TPBSSRow;
begin
  Result := TPBSSRow(Controls[Index]);
end;

procedure TPBSSView.PaintWindow(DC: HDC);
begin
  {eat inherited}
end;

procedure TPBSSView.WMEnterSizeMove(var Message: TMessage);
begin
  if not AlignDisabled then
    DisableAlign;
  inherited;
end;

procedure TPBSSView.WMEraseBkgnd(var Message: TWmEraseBkgnd);
var
  DC: HDC;
begin
  DC := GetDC(Handle);
  try
    FillRect(DC,Rect(0,VertScrollBar.Range,Height),Brush.Handle);
  finally
    ReleaseDC(Handle,DC);
  end;
  Message.Result := 1;
end;

procedure TPBSSView.WMExitSizeMove(var Message: TMessage);
begin
  inherited;
  if AlignDisabled then
    EnableAlign;
end;

end.

如果仍然表现不佳,那么还有其他多项增强功能可能.

更新:

>通过覆盖/拦截WM_ERASEBKGND(并拦截版本< XE2的PaintWindow)来消除闪烁,
通过使用DisableAlign和EnableAlign来提高性能.

原文链接:https://www.f2er.com/delphi/101239.html

猜你在找的Delphi相关文章