티스토리 뷰

Programming/Delphi - FireMonkey

FireMonkey - Canvas Free Drawing

파란크리스마스 2014. 5. 14. 10:05
728x90

출처 : 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.

 

댓글
300x250
공지사항
최근에 올라온 글
최근에 달린 댓글
Total
Today
Yesterday
«   2024/03   »
1 2
3 4 5 6 7 8 9
10 11 12 13 14 15 16
17 18 19 20 21 22 23
24 25 26 27 28 29 30
31
글 보관함