Delphi 10.1 FMX 如何将 RoundRect 位图和 TPath 复制到 TImage

Question

我正在使用 Delphi 10.1 并且有一个多设备应用程序。

我正在将图像加载到 TRoundRect 控件中，用户可以在其中直接绘制。

我的问题是如何将 RoundRect Image 及其上绘制的内容复制到 TImage？

这是表格：-

object frmMain: TfrmMain
  Left = 0
  Top = 0
  Caption = 'Form1'
  ClientHeight = 528
  ClientWidth = 759
  FormFactor.Width = 320
  FormFactor.Height = 480
  FormFactor.Devices = [Desktop]
  DesignerMasterStyle = 0
  object tbPhoto: TToolBar
    Align = Bottom
    Position.Y = 432.000000000000000000
    Size.Width = 759.000000000000000000
    Size.Height = 48.000000000000000000
    Size.PlatformDefault = False
    TabOrder = 1
    object btnReset: TButton
      Align = Left
      Margins.Left = 5.000000000000000000
      Margins.Top = 5.000000000000000000
      Margins.Right = 5.000000000000000000
      Margins.Bottom = 5.000000000000000000
      Position.X = 5.000000000000000000
      Position.Y = 5.000000000000000000
      Size.Width = 82.000000000000000000
      Size.Height = 38.000000000000000000
      Size.PlatformDefault = False
      TabOrder = 0
      Text = 'Reset'
      OnClick = btnResetClick
    end
    object btnCopy_File_Image_To_RoundRect: TButton
      Align = Left
      Margins.Left = 5.000000000000000000
      Margins.Top = 5.000000000000000000
      Margins.Right = 5.000000000000000000
      Margins.Bottom = 5.000000000000000000
      Position.X = 97.000000000000000000
      Position.Y = 5.000000000000000000
      Size.Width = 176.000000000000000000
      Size.Height = 38.000000000000000000
      Size.PlatformDefault = False
      TabOrder = 2
      Text = 'Copy File Image To RoundRect '
      OnClick = btnCopy_File_Image_To_RoundRectClick
    end
    object btnCopy_Round_Rect_To_Image: TButton
      Align = Left
      Margins.Left = 5.000000000000000000
      Margins.Top = 5.000000000000000000
      Margins.Right = 5.000000000000000000
      Margins.Bottom = 5.000000000000000000
      Position.X = 283.000000000000000000
      Position.Y = 5.000000000000000000
      Size.Width = 190.000000000000000000
      Size.Height = 38.000000000000000000
      Size.PlatformDefault = False
      TabOrder = 1
      Text = 'Copy RoundRect to Image'
      OnClick = btnCopy_Round_Rect_To_ImageClick
    end
  end
  object ToolBar2: TToolBar
    Size.Width = 759.000000000000000000
    Size.Height = 41.000000000000000000
    Size.PlatformDefault = False
    TabOrder = 4
    object Label1: TLabel
      Align = Client
      Size.Width = 759.000000000000000000
      Size.Height = 41.000000000000000000
      Size.PlatformDefault = False
      TextSettings.HorzAlign = Center
      Text = 'Image Photo Draw'
    end
  end
  object RoundRect1: TRoundRect
    Align = Left
    Corners = []
    Fill.Kind = None
    Margins.Left = 5.000000000000000000
    Margins.Top = 5.000000000000000000
    Margins.Right = 5.000000000000000000
    Margins.Bottom = 5.000000000000000000
    Position.X = 5.000000000000000000
    Position.Y = 46.000000000000000000
    Size.Width = 372.000000000000000000
    Size.Height = 381.000000000000000000
    Size.PlatformDefault = False
    Stroke.Thickness = 2.000000000000000000
    Stroke.Dash = Dash
    OnMouseDown = RoundRect1MouseDown
    OnMouseMove = RoundRect1MouseMove
    object Path1: TPath
      Align = Client
      Fill.Kind = None
      Locked = True
      HitTest = False
      Size.Width = 372.000000000000000000
      Size.Height = 381.000000000000000000
      Size.PlatformDefault = False
      Stroke.Color = claRed
      Stroke.Thickness = 2.000000000000000000
      WrapMode = Original
    end
  end
  object tbImage: TToolBar
    Align = Bottom
    Position.Y = 480.000000000000000000
    Size.Width = 759.000000000000000000
    Size.Height = 48.000000000000000000
    Size.PlatformDefault = False
    TabOrder = 0
    object btnDraw_Colour: TButton
      Align = Right
      Margins.Left = 5.000000000000000000
      Margins.Top = 5.000000000000000000
      Margins.Right = 5.000000000000000000
      Margins.Bottom = 5.000000000000000000
      Position.X = 580.000000000000000000
      Position.Y = 5.000000000000000000
      Size.Width = 82.000000000000000000
      Size.Height = 38.000000000000000000
      Size.PlatformDefault = False
      TabOrder = 1
      Text = 'Black'
      OnClick = btnDraw_ColourClick
    end
    object btnClear_Drawing: TButton
      Tag = 1
      Align = Right
      Margins.Left = 5.000000000000000000
      Margins.Top = 5.000000000000000000
      Margins.Right = 5.000000000000000000
      Margins.Bottom = 5.000000000000000000
      Position.X = 672.000000000000000000
      Position.Y = 5.000000000000000000
      Size.Width = 82.000000000000000000
      Size.Height = 38.000000000000000000
      Size.PlatformDefault = False
      TabOrder = 0
      Text = 'Clear'
      OnClick = btnClear_DrawingClick
    end
  end
  object Image1: TImage
    MultiResBitmap = <
      item
      end>
    Align = Client
    Size.Width = 377.000000000000000000
    Size.Height = 391.000000000000000000
    Size.PlatformDefault = False
    WrapMode = Stretch
  end
end

这是我目前的代码：-

unit uMain;

interface

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

const
  Con_Draw_Colour_Red = 0;
  Con_Draw_Colour_Black = 1;

  Con_Max_Draw_Colours = Con_Draw_Colour_Black;

  Con_Draw_Colours: array[0..Con_Max_Draw_Colours] of String = ('Red', 'Black');

type
  TfrmMain = class(TForm)
    tbPhoto: TToolBar;
    ToolBar2: TToolBar;
    Label1: TLabel;
    btnReset: TButton;
    RoundRect1: TRoundRect;
    Path1: TPath;
    tbImage: TToolBar;
    btnDraw_Colour: TButton;
    btnClear_Drawing: TButton;
    Image1: TImage;
    btnCopy_File_Image_To_RoundRect: TButton;
    btnCopy_Round_Rect_To_Image: TButton;
    procedure btnResetClick(Sender: TObject);
    procedure RoundRect1MouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Single);
    procedure RoundRect1MouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Single);
    procedure btnDraw_ColourClick(Sender: TObject);
    procedure btnClear_DrawingClick(Sender: TObject);
    procedure btnCopy_File_Image_To_RoundRectClick(Sender: TObject);
    procedure btnCopy_Round_Rect_To_ImageClick(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  frmMain: TfrmMain;

implementation

uses
  FMX.Platform,
  FMX.MediaLibrary;

{$R *.fmx}

procedure TfrmMain.btnClear_DrawingClick(Sender: TObject);
begin
  {$REGION 'Clear the Drawing'}
  Path1.Data.Clear;
  {$ENDREGION 'Clear the Drawing'}
end;

procedure TfrmMain.btnDraw_ColourClick(Sender: TObject);
begin
  {$REGION 'Change the Path Stroke Colour'}
  btnDraw_Colour.Text := Con_Draw_Colours[(Sender as TButton).Tag];
  case (Sender as TButton).Tag of
    Con_Draw_Colour_Red   : begin
                              (Sender as TButton).Tag := Con_Draw_Colour_Black;
                              Path1.Stroke.Color := TAlphaColorRec.Black;
                            end;
    Con_Draw_Colour_Black : begin
                              (Sender as TButton).Tag := Con_Draw_Colour_Red;
                              Path1.Stroke.Color := TAlphaColorRec.Red;
                            end;
  end;
  {$ENDREGION 'Change the Path Stroke Colour'}
end;

procedure TfrmMain.btnResetClick(Sender: TObject);
begin
  {$REGION 'Clear the Photo and Drawing'}
  Image1.Bitmap := nil;
  RoundRect1.Fill.Bitmap.Bitmap := nil;
  btnClear_DrawingClick(Sender);
  {$ENDREGION 'Clear the Photo and Drawing'}
end;

procedure TfrmMain.btnCopy_File_Image_To_RoundRectClick(Sender: TObject);
begin
  RoundRect1.Fill.Kind := TbrushKind.Bitmap;
  RoundRect1.Fill.Bitmap.WrapMode := TWrapMode.TileStretch;
  RoundRect1.Fill.Bitmap.Bitmap.LoadFromFile('...\The Image.jpg');
end;

procedure TfrmMain.btnCopy_Round_Rect_To_ImageClick(Sender: TObject);
begin
  {$REGION 'Draw the users lines on the Image'}
  {$REGION 'Set the Bitmap Stroke Colour'}
  case btnDraw_Colour.Tag of
    Con_Draw_Colour_Red   : RoundRect1.Fill.Bitmap.Bitmap.Canvas.Stroke.Color := TAlphaColorRec.Red;
    Con_Draw_Colour_Black : RoundRect1.Fill.Bitmap.Bitmap.Canvas.Stroke.Color := TAlphaColorRec.Black;
  end;
  {$ENDREGION 'Set the Bitmap Stroke Colour'}

  RoundRect1.Fill.Bitmap.Bitmap.Canvas.BeginScene;
  RoundRect1.Fill.Bitmap.Bitmap.Canvas.DrawPath(Path1.Data, 2);
  RoundRect1.Fill.Bitmap.Bitmap.Canvas.EndScene;
  {$ENDREGION 'Draw the users lines on the Image'}

  Image1.Bitmap.Assign(RoundRect1.Fill.Bitmap.Bitmap);
end;

procedure TfrmMain.RoundRect1MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Single);
begin
  if ssLeft in Shift then
    Path1.Data.MoveTo((TPointF.Create(X, Y)));
end;

procedure TfrmMain.RoundRect1MouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Single);
begin
  {$REGION 'Draw the line only if we have a Image'}
  if (not RoundRect1.Fill.Bitmap.Bitmap.IsEmpty) then
  begin
    if ssLeft in Shift  then
    begin
      Path1.Data.LineTo((TPointF.Create(X, Y)));
      RoundRect1.Repaint;
    end;
  end;
  {$ENDREGION 'Draw the line only if we have a Image'}
end;

end.

这是我想将 RoundRect 及其上绘制的内容复制到 TImage 的地方。加载的图像复制但不复制绘制的内容：-

procedure TfrmMain.btnCopy_Round_Rect_To_ImageClick(Sender: TObject);
begin
  {$REGION 'Draw the users lines on the Image'}
  {$REGION 'Set the Bitmap Stroke Colour'}
  case btnDraw_Colour.Tag of
    Con_Draw_Colour_Red   : RoundRect1.Fill.Bitmap.Bitmap.Canvas.Stroke.Color := TAlphaColorRec.Red;
    Con_Draw_Colour_Black : RoundRect1.Fill.Bitmap.Bitmap.Canvas.Stroke.Color := TAlphaColorRec.Black;
  end;
  {$ENDREGION 'Set the Bitmap Stroke Colour'}

  RoundRect1.Fill.Bitmap.Bitmap.Canvas.BeginScene;
  RoundRect1.Fill.Bitmap.Bitmap.Canvas.DrawPath(Path1.Data, 2);
  RoundRect1.Fill.Bitmap.Bitmap.Canvas.EndScene;
  {$ENDREGION 'Draw the users lines on the Image'}

  Image1.Bitmap.Assign(RoundRect1.Fill.Bitmap.Bitmap);
end;

TImage WrapMode 设置为 Stretch，因此绘制的内容需要成比例。

知道如何复制 RoundRect 位图和绘制的内容吗？

希望这是有道理的。蒂亚

Answer 1

图片正在拉伸，但路径对象没有，所以当它被绘制在 TImage 上时，它会与图片一起拉伸并且比例错误。您也没有设置绘制路径的笔触粗细。以下是缩放路径绘图以匹配图片的一种解决方案。 Math.Vectors 需要使用。在 Delphi 10.4.

中测试

procedure TfrmMain.btnCopy_Round_Rect_To_ImageClick(Sender: TObject);
var
  M : TMatrix;
  ScaleX, ScaleY : Single;
begin
  {$REGION 'Draw the users lines on the Image'}
  {$REGION 'Set the Bitmap Stroke Colour'}
  case btnDraw_Colour.Tag of
    Con_Draw_Colour_Red   : RoundRect1.Fill.Bitmap.Bitmap.Canvas.Stroke.Color := TAlphaColorRec.Red;
    Con_Draw_Colour_Black : RoundRect1.Fill.Bitmap.Bitmap.Canvas.Stroke.Color := TAlphaColorRec.Black;
  end;
  {$ENDREGION 'Set the Bitmap Stroke Colour'}

  RoundRect1.Fill.Bitmap.Bitmap.Canvas.BeginScene;
  ScaleX := RoundRect1.Fill.Bitmap.Bitmap.Width / RoundRect1.Width;
  ScaleY := RoundRect1.Fill.Bitmap.Bitmap.Height / RoundRect1.Height;
  M := TMatrix.CreateScaling(ScaleX, ScaleY);
  RoundRect1.Fill.Bitmap.Bitmap.Canvas.SetMatrix(M);
  RoundRect1.Fill.Bitmap.Bitmap.Canvas.Stroke.Thickness := Path1.Stroke.Thickness;
  RoundRect1.Fill.Bitmap.Bitmap.Canvas.DrawPath(Path1.Data, 1);
  RoundRect1.Fill.Bitmap.Bitmap.Canvas.EndScene;
  {$ENDREGION 'Draw the users lines on the Image'}

  Image1.Bitmap.Assign(RoundRect1.Fill.Bitmap.Bitmap);
end;

Delphi 10.1 FMX 如何将 RoundRect 位图和 TPath 复制到 TImage

Delphi 10.1 FMX How to copy a RoundRect Bitmap and TPath onto a TImage

delphi

firemonkey