Delphi10.1FMX如何將RoundRect位圖和TPath復制到TImage上-有解無憂

我正在使用 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
    onm ouseDown = RoundRect1MouseDown
    onm ouseMove = 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 位圖以及繪制了什么？

希望這是有道理的。蒂亞

uj5u.com熱心網友回復：

圖片正在被拉伸，但路徑物件沒有被拉伸，所以當它被繪制在 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;

轉載請註明出處，本文鏈接：https://www.uj5u.com/gongcheng/389667.html

標籤：德尔福火猴

上一篇：查詢以查找最近日期為檔案插入的記錄數

下一篇：如何從具有相同名稱的兩個介面實作兩個方法？