我使用的是Delphi 10.1，有一个多设备应用程序。
我正在将图像加载到TRoundRect控件上，用户可以直接在该控件上绘制
我的问题是如何将RoundRect图像及其上绘制的内容复制到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包裹模式设置为拉伸，因此绘制的内容需要成比例。
有什么想法如何复制RoundRect位图和绘制的内容吗？
希望这是有道理的。tia
图片正在拉伸，但路径对象没有，因此当它被绘制在TImage上时，它将与图片一起拉伸，并具有错误的比例。您也没有设置绘制路径的笔划厚度。以下是一种缩放路径图形以匹配图片的解决方案。使用时需要使用数学矢量。在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;