Delphi 11.1 在FMX Image上畫圖遇到坑

 

 

上圖是運行后的結果，正常左右兩圖應該是一樣的結果，都在圖上畫出一個紅框。

下圖是實現的代碼：

unit Unit1;

interface

uses
  System.SysUtils, System.Types, System.UITypes, System.Classes, System.Variants,
  FMX.Types, FMX.Controls, FMX.Forms, FMX.Graphics, FMX.Dialogs,
  FMX.Controls.Presentation, FMX.StdCtrls, FMX.Objects;

type
  TForm1 = class(TForm)
    Image1: TImage;
    Image2: TImage;
    Button1: TButton;
    Button2: TButton;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
  private
    procedure DrawRect(aBitMap: TBitMap);
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.fmx}

procedure TForm1.Button1Click(Sender: TObject);
begin
//左圖的算法
//在Image.Bitmap上直接畫，結果不對
  Image1.Bitmap.LoadFromFile('.\5.jpg');
  DrawRect(Image1.Bitmap);
end;

procedure TForm1.Button2Click(Sender: TObject);
var
  aBitmap:TBitmap;
  aImage:TImage;
begin
//右圖的算法
//在右圖上，正確的畫出紅框
  aBitmap:=TBitmap.Create;
  aBitmap.LoadFromFile('.\5.jpg');
  DrawRect(aBitmap);
  Image2.Bitmap.Assign(abitmap);
  aBitmap.Free;

// 這樣也可以
//  aImage:=TImage.Create(Self);
//  aImage.Bitmap.LoadFromFile('.\5.jpg');
//  DrawRect(aImage.Bitmap);
//  Image2.Bitmap.Assign(aImage.Bitmap);
//  aImage.Free;
end;

procedure TForm1.DrawRect(aBitMap: TBitMap);
var
  r: TRectF;
  aLeft, aTop, aHeight, aWidth, aRight, aBottom: single;
  i: Integer;
begin

  aTop:=217;
  aLeft:= 767;
  aHeight:= 258;
  aWidth:= 198;
  aBottom:=aTop+aHeight;
  aRight:=aLeft+aWidth;

  aBitMap.Canvas.BeginScene;
  try
    r := TRectF.Create(aLeft, aTop, aRight, aBottom);
    with aBitMap.Canvas do
    begin
      Stroke.Kind := TBrushKind.Solid;
      Stroke.Color := TAlphaColors.red;
      Stroke.Thickness := 8;
      DrawRect(r, 0, 0, AllCorners, 1.0);
    end;
  finally
    aBitMap.Canvas.EndScene;
  end;
end;

end.

也問了朋友，說可能是bug，正在幫我檢查問題，我感覺兩種寫法應該是一樣的結果，確實是問題，害得我好幾個小時懷疑自己的寫法問題。

說白了，直接在Image上畫，結果不對，而建立一個Bitmap，在上面畫，再調入image就正常，這算什么事啊？！

在朋友們的幫助下，又搞了半宿，結果更離奇了！！！

朋友們在他們的環境運行，結果是正常的。

Aone老師真是強，幫我查出原因，原來是high-dpi的問題，DrawRect代碼改成這樣，解決了！

procedure TForm1.DrawRect(aBitMap: TBitMap);
var
  r: TRectF;
  aLeft, aTop, aHeight, aWidth, aRight, aBottom: single;
  i: Integer;
begin

  aTop:=217;
  aLeft:= 767;
  aHeight:= 258;
  aWidth:= 198;
  aBottom:=aTop+aHeight;
  aRight:=aLeft+aWidth;

  aBitMap.Canvas.BeginScene;
  try
    r := TRectF.Create(aLeft/aBitMap.Canvas.Scale, aTop/aBitMap.Canvas.Scale, aRight/aBitMap.Canvas.Scale, aBottom/aBitMap.Canvas.Scale);
    with aBitMap.Canvas do
    begin
      Stroke.Kind := TBrushKind.Solid;
      Stroke.Color := TAlphaColors.red;
      Stroke.Thickness := 8/aBitMap.Canvas.Scale;
      DrawRect(r, 0, 0, AllCorners, 1.0);
    end;
  finally
    aBitMap.Canvas.EndScene;
  end;
end;

end.

上面代碼我標紅的地方，問題解決，如下圖：

 

最后，感謝昨晚一起幫助我的朋友們！

繼續居家隔離，期待疫情早日過去，更期待11.2早點發布！