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早点发布！