delphi - Graphics32 层性能问题

Question

我使用 graphics32 库在 Delphi 中开发了一个应用程序。它涉及向 ImgView32 控件添加层。它现在可以满足我的所有需求，除了当用户向 ImgView 添加超过 25-30 层时，所选层开始表现不佳。我的意思是，-当 ImgView32 上有 30 多个图层并且我单击一个图层时，实际选择它大约需要 2.5-2 秒。- 此外，当我尝试移动图层时，它会突然移动

当有更多层时，似乎 ImgViewChange 被调用了太多次。PaintLayer 也是如此。它被调用太多次了。我怎样才能阻止这种情况发生？即使添加了超过 30 个图层，我如何才能使图层优雅地移动？

我的代码如下：

procedure TMainForm.LayerMouseDown(Sender: TObject; Buttons: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  cronstart:=now;
  if Sender <> nil then
  begin
    Selection := TPositionedLayer(Sender);
  end
  else
  begin
  end;
  cronstop:=now;
  Memo1.Lines.Add('LayerMouseDown:'+FloatToStr((cronstop-cronstart)*secsperDay)+'sec');
end;

procedure TMainForm.AddSpecialLineLayer(tip:string);
var
  B: TBitmapLayer;
  P: TPoint;
  W, H: Single;
begin
      B := TBitmapLayer.Create(ImgView.Layers);
      with B do
      try
        Bitmap.SetSize(100,100);
        Bitmap.DrawMode := dmBlend;

        with ImgView.GetViewportRect do
          P := ImgView.ControlToBitmap(GR32.Point((Right + Left) div 2, (Top + Bottom) div 2));

        W := Bitmap.Width * 0.5;
        H := Bitmap.Height * 0.5;

        with ImgView.Bitmap do
          Location := GR32.FloatRect(P.X - W, P.Y - H, P.X + W, P.Y + H);

        Scaled := True;
        OnMouseDown := LayerMouseDown;
        B.OnPaint := PaintGeamOrizHandler

      except
        Free;
        raise;
      end;
      Selection := B;
end;

procedure TMainForm.PaintGeamOrizHandler(Sender: TObject;Buffer: TBitmap32);
var
  bmp32:TBitmap32;
  R:TRect;
  usa2:single;
  latime,inaltime,usa:Single;
  inaltime2, latime2:single;
begin
  cronstart:=now;
  if Sender is TBitmapLayer then
    with TBitmapLayer(Sender).GetAdjustedLocation do
    begin
      bmp32:=TBitmap32.Create;
      try
            R := MakeRect(TBitmapLayer(Sender).GetAdjustedLocation);
            bmp32.DrawMode:=dmblend;
            bmp32.SetSize(Round(Right-Left), Round(Bottom-Top));

            latime:=Round((Right-Left));
            inaltime:=Round((Bottom-Top));
            usa:=60;
            usa2:=usa / 2;
            with TLine32.Create do
              try
                  EndStyle := esClosed;
                  JoinStyle := jsMitered;
                  inaltime2:=inaltime / 2;
                  latime2:=latime / 2;

                  SetPoints([FixedPoint(latime2-usa2,inaltime2), FixedPoint(latime2+usa2,inaltime2)]);
                  Draw(bmp32, 13, clWhite32);
                  SetPoints(GetOuterEdge);
                  Draw(bmp32, 1.5, clBlack32);

                  SetPoints([FixedPoint(latime2-usa2-3,inaltime2), FixedPoint(latime2-usa2,inaltime2)]);
                  Draw(bmp32, 5, clBlack32);

                  SetPoints([FixedPoint(latime2-usa2-3-7,inaltime2), FixedPoint(latime2-usa2-3,inaltime2)]);
                  Draw(bmp32, 7, clWhite32);
                  SetPoints(GetOuterEdge);
                  Draw(bmp32, 1.5, clBlack32);

                  SetPoints([FixedPoint(latime2+usa2,inaltime2), FixedPoint(latime2+usa2+3,inaltime2)]);
                  Draw(bmp32, 5, clBlack32);

                  SetPoints([FixedPoint(latime2+usa2+3+7,inaltime2), FixedPoint(latime2+usa2+3,inaltime2)]);
                  Draw(bmp32, 7, clWhite32);
                  SetPoints(GetOuterEdge);
                  Draw(bmp32, 1.5, clBlack32);

              finally
                Free;
              end;
            (Sender as TBitmapLayer).Bitmap.Assign(bmp32);
      finally
        bmp32.Free;
      end;
    end;
  cronstop:=now;
  Memo1.Lines.Add('PaintLayer:'+FloatToStr((cronstop-cronstart)*secsperDay)+'sec');    
end;

procedure TMainForm.SetSelection(Value: TPositionedLayer);
begin
  if Value<>nil then
  begin
    if Value <> FSelection then
    begin
                  if RBLayer <> nil then
                  begin
                    RBLayer.ChildLayer := nil;
                    RBLayer.LayerOptions := LOB_NO_UPDATE;
                  end;
                  FSelection := Value;
                  if Value <> nil then
                  begin
                        if RBLayer = nil then
                        begin
                          RBLayer := TRubberBandLayer.Create(ImgView.Layers);
                          RBLayer.MinHeight := 1;
                          RBLayer.MinWidth := 1;
                        end
                        else
                          RBLayer.BringToFront;
                        RBLayer.ChildLayer := Value;
                        RBLayer.LayerOptions := LOB_VISIBLE or LOB_MOUSE_EVENTS or LOB_NO_UPDATE;
                        RBLayer.OnResizing := RBResizing;
                  end;
    end;
  end;
end;


procedure TMainForm.RBResizing(Sender: TObject;
  const OldLocation: TFloatRect; var NewLocation: TFloatRect;
  DragState: TRBDragState; Shift: TShiftState);
var
  w, h, cx, cy: Single;
  nw, nh: Single;
begin
cronstart:=now;
  if DragState = dsMove then Exit; // we are interested only in scale operations
  if Shift = [] then Exit; // special processing is not required

  if ssCtrl in Shift then
  begin
    { make changes symmetrical }

    with OldLocation do
    begin
      cx := (Left + Right) / 2;
      cy := (Top + Bottom) / 2;
      w := Right - Left;
      h := Bottom - Top;
    end;

    with NewLocation do
    begin
      nw := w / 2;
      nh := h / 2;
      case DragState of
        dsSizeL: nw := cx - Left;
        dsSizeT: nh := cy - Top;
        dsSizeR: nw := Right - cx;
        dsSizeB: nh := Bottom - cy;
        dsSizeTL: begin nw := cx - Left; nh := cy - Top; end;
        dsSizeTR: begin nw := Right - cx; nh := cy - Top; end;
        dsSizeBL: begin nw := cx - Left; nh := Bottom - cy; end;
        dsSizeBR: begin nw := Right - cx; nh := Bottom - cy; end;
      end;
      if nw < 2 then nw := 2;
      if nh < 2 then nh := 2;
      Left := cx - nw;
      Right := cx + nw;
      Top := cy - nh;
      Bottom := cy + nh;
    end;
  end;
  cronstop:=now;
  Memo1.Lines.Add('RBResizing:'+FloatToStr((cronstop-cronstart)*secsperDay)+'sec');
end;


procedure TMainForm.ImgViewChange(Sender: TObject);
var
  wid,hei:Integer;
begin
  Edit1.Text:=IntToStr(StrToInt(Edit1.Text)+1);
  cronstart:=now;
  if Selection = nil then
  begin
  end
  else
  begin
        wid:=Round(Selection.Location.Right-Selection.Location.Left);
        hei:=Round(Selection.Location.Bottom-Selection.Location.Top);
//        SelectLayerPan(Selection.Index);
  end;
  cronstop:=now;
  Memo1.Lines.Add('ImgViewChange:'+FloatToStr((cronstop-cronstart)*secsperDay)+'sec');
end;

procedure TMainForm.ImgViewMouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer; Layer: TCustomLayer);
begin
  Edit1.Text:='0';
  cronstart:=now;
  if Layer = nil then
  begin
                  if Assigned(FSelection) then
                      begin
                          Selection := nil;
                            RBLayer.Visible:=false;
                        end;
  end
  else
  begin
//                  SelectLayerPan(layer.Index);
  end;
  cronstop:=now;
  Memo1.Lines.Add('imgViewMouseDown:'+FloatToStr((cronstop-cronstart)*secsperDay)+'sec');
end;


procedure TMainForm.ImgViewPaintStage(Sender: TObject; Buffer: TBitmap32;
  StageNum: Cardinal);
const            //0..1
  Colors: array [Boolean] of TColor32 = ($FFFFFFFF, $FFB0B0B0);
var
  R: TRect;
  I, J: Integer;
  OddY: Integer;
  TilesHorz, TilesVert: Integer;
  TileX, TileY: Integer;
  TileHeight, TileWidth: Integer;
begin
  TileHeight := 13;
  TileWidth := 13;

  TilesHorz := Buffer.Width div TileWidth;
  TilesVert := Buffer.Height div TileHeight;
  TileY := 0;

  for J := 0 to TilesVert do
  begin
    TileX := 0;
    OddY := J and $1;
    for I := 0 to TilesHorz do
    begin
      R.Left := TileX;
      R.Top := TileY;
      R.Right := TileX + TileWidth;
      R.Bottom := TileY + TileHeight;
      Buffer.FillRectS(R, Colors[I and $1 = OddY]);
      Inc(TileX, TileWidth);
    end;
    Inc(TileY, TileHeight);
  end;
end;




procedure TMainForm.Button1Click(Sender: TObject);
begin
  Edit1.Text:='0';
   MainForm.AddSpecialLineLayer('geams'); //orizontal
end;

因此，只需多次单击按钮（30 次），一旦添加了 25-30 层，您就会注意到异常行为。（当然使用库中层示例中的基本代码并添加上述程序）

也许解决方案是在某处禁用 ImgViewChange 事件的触发。但我不知道在哪里做……或者我错了。

请给我一个解决这个问题的方法......因为我想不出任何东西......

编辑这是一个可以更好地解释的屏幕截图：在此处输入图像描述

正如您在 imgView 的右侧看到的，有 3 个编辑框。第一个告诉我们已经添加了 25 层。另外两个也是不言自明的。在图片的左侧，您可以看到那里绘制的图层。它们都是一样的，都是用代码中的paintHandler绘制的。所以所有层都是相同的

现在考虑这种情况：没有选择图层，然后我开始单击图层，前 3 次单击显示 ImgViewChange=52 和 Paint=26，每个图层。然后在我第四次单击图层时，值就是此处显示的图像中的值。这没有任何意义。所以 ImgViewChanged 被调用了 1952 次， PaintHandler 被调用了 976 次。某处一定有一个错误......请帮我解决这个问题。考虑到这些编辑框已填写在上面的代码中。同样在这个测试项目中，没有其他代码可以做这种疯狂的行为。我只使用使其工作所需的代码编写了这个测试项目。所以代码在上面，行为在图片中。

编辑在 PaintHandler 方法中添加 bmp32.BeginUpdate 和 bmp32.EndUpdate 后，重绘和 imgViewChanges 的数量似乎减少了，但没有减少很多。现在我得到 ImgViewChange=1552 和 PaintHandler=776。我什至不确定这是因为我的改变，因为这些数字看起来几乎是随机的。我的意思是我不知道它为什么会发生，谁会定期触发这些事件，以及当它们被触发这么多次时会发生什么？

当我将所有 25 个图层添加到 imgView 时，我将它们留在添加它们的位置：在视图的中心。全部添加后，我开始单击每个并将它们拖离中心，以便它们都可见。

现在，我单击并从中心拖动的前 15-20 层，我监控的 2 个数字（这两个事件被触发的次数）比我想要的第 20 层之后得到的数字低很多从中心拖动。当它们都分散在视图中之后，它就开始了：一些图层可以实时点击，其他图层需要一段时间才能被选中，而我对事件触发的计数已经超过了屋顶。

编辑

我发现了我的问题。有了这个，我将被触发的事件数量减少到正常数量。所以解决方案是为图层位图的分配添加 BeginUpdate 和 EndUpdate ......所以在 PaintHandler 我将代码更改为：

  (Sender as TBitmapLayer).BeginUpdate;
  (Sender as TBitmapLayer).Bitmap.Assign(bmp32);
  (Sender as TBitmapLayer).EndUpdate;

现在我的图层表现得像他们应该的那样。感谢 SilverWarrior 为我指明了正确的方向。请将您的评论转换为答案，以便我接受。

score 2 · Accepted Answer

BeginUpdate/EndUpdate 有利于减少 ImgViewChange 事件的数量，如此处所述

OnChange 是一个抽象的更改通知事件，由 TCustomPaintBox32 的一些后代在其内容发生更改后立即调用。例如，在 TCustomImage32 中，这包括从包含的位图和图层重定向更改通知事件。但是，TCustomPaintBox32 控件本身不会调用此事件，除非您显式调用 Changed 方法。更改通知可以通过 BeginUpdate 调用禁用，并通过 EndUpdate 调用重新启用。

但是，您的代码中还有其他问题：

在AddSpecialLineLayer()您创建一个新的TBitmapLayer，设置其大小和位置Bitmap并将其OnPaint处理程序设置为PaintGeamOrizHandler()。这本身不是问题，但它是迈向真正问题的第一步。
主要思想似乎是绘制一些形状，但PaintGeamOrizHandler()这样做的方式非常耗时，没有任何好处。首先你创建一个新的TBitmap32. 然后在该位图上绘制形状。然后将其分配给图层位图。最后释放刚刚创建的位图。所有的形状绘制都可以直接在图层位图上完成。“临时”位图只是 CPU 资源的腰部。
但另一个问题是，为什么每次需要绘制图层时都要绘制形状？TBitmapLayer 的位图完全能够保留形状，直到您特别需要更改它们。相反，您可以在创建图层时（和/或需要更改形状时）在单独的过程中一次性绘制形状。

您可能还想探索绘制阶段的文档，也许还想重新绘制优化器

delphi - Graphics32 层性能问题

1 回答 1

Related

Reference