FireMonkey - Canvas Free Drawing

출처 : Delphi Firemonkey 개발자 모임

TestPG.7z

Code

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.Objects;

type
  TForm1 = class(TForm)
    Image1: TImage;
    procedure Image1MouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Single);
    procedure Image1MouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Single);
    procedure Image1MouseUp(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Single);
    procedure FormShow(Sender: TObject);
  private
    { Private declarations }
    FDownPos: TPointF;
    AMouseDownCheck: Boolean;
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

uses
  FMX.Platform;

{$R *.fmx}

procedure TForm1.FormShow(Sender: TObject);
var
  ScreenScale: Single;
  ScreenSvc: IFMXScreenService;
begin
  if TPlatformServices.Current.SupportsPlatformService(IFMXScreenService, IInterface(ScreenSvc)) then
  begin
    ScreenScale := ScreenSvc.GetScreenScale;
  end;

  Image1.Bitmap.Width := Round(Self.Width * ScreenScale);
  Image1.Bitmap.Height := Round(Self.Height * ScreenScale);
  Image1.Bitmap.Clear(TAlphaColorRec.White);
end;

procedure TForm1.Image1MouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Single);
begin
  FDownPos := PointF(X, Y);
  AMouseDownCheck := True;
end;

procedure TForm1.Image1MouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Single);
begin
  if AMouseDownCheck then
  begin
    with Image1.Bitmap.Canvas do
    begin
      BeginScene();
      Stroke.Color := TAlphaColors.Black;
      StrokeThickness := 2;
      DrawLine(FDownPos, PointF(X, Y), 1);
      EndScene;
    end;
    FDownPos := PointF(X, Y);
  end;
end;

procedure TForm1.Image1MouseUp(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Single);
begin
  AMouseDownCheck := False;
end;

end.