Unit1.pas

   1 unit Unit1;
   2
   3 interface
   4
   5 uses
   6   System.SysUtils, System.Types, System.UITypes, System.Classes,
   7   System.Variants,
   8   FMX.Types, FMX.Controls, FMX.Forms, FMX.Dialogs, FMX.Ani, FMX.Layouts,
   9   FMX.Gestures,
  10   FMX.StdCtrls, FMX.TreeView, FMX.ListBox, FMX.Controls.Presentation, FMX.Edit,
  11   FMX.EditBox, FMX.SpinBox, FMX.Graphics, System.Math, FMX.Effects,
  12   FMX.Filter.Effects;
  13
  14 type
  15   TForm1 = class(TForm)
  16     ToolbarHolder: TLayout;
  17     ToolbarPopup: TPopup;
  18     ToolbarPopupAnimation: TFloatAnimation;
  19     ToolBar1: TToolBar;
  20     ToolbarApplyButton: TButton;
  21     ToolbarCloseButton: TButton;
  22     ToolbarAddButton: TButton;
  23     Panel1: TPanel;
  24     Button2: TButton;
  25     Button3: TButton;
  26     CheckBox1: TCheckBox;
  27     Label1: TLabel;
  28     RadioButton1: TRadioButton;
  29     RadioButton2: TRadioButton;
  30     OpenDialog1: TOpenDialog;
  31     ListBox1: TListBox;
  32     Button1: TButton;
  33     Button4: TButton;
  34     Button5: TButton;
  35     Button6: TButton;
  36     Button7: TButton;
  37     Button8: TButton;
  38     SpinBox1: TSpinBox;
  39     SpinBox2: TSpinBox;
  40     Button11: TButton;
  41     Button12: TButton;
  42     SpinBox3: TSpinBox;
  43     Label2: TLabel;
  44     ImageControl1: TImageControl;
  45     PathLabel1: TPathLabel;
  46     Button9: TButton;
  47     Label3: TLabel;
  48     procedure ToolbarCloseButtonClick(Sender: TObject);
  49     procedure FormGesture(Sender: TObject; const EventInfo: TGestureEventInfo;
  50       var Handled: Boolean);
  51     procedure FormKeyDown(Sender: TObject; var Key: Word; var KeyChar: Char;
  52       Shift: TShiftState);
  53     procedure Button3Click(Sender: TObject);
  54     procedure Button11Click(Sender: TObject);
  55     procedure Button9Click(Sender: TObject);
  56     procedure Button1Click(Sender: TObject);
  57     procedure ListBox1Change(Sender: TObject);
  58     procedure FormPaint(Sender: TObject; Canvas: TCanvas; const ARect: TRectF);
  59     procedure Button4Click(Sender: TObject);
  60     procedure Button7Click(Sender: TObject);
  61     procedure Button8Click(Sender: TObject);
  62     procedure SpinBox3Change(Sender: TObject);
  63     procedure FormMouseDown(Sender: TObject; Button: TMouseButton;
  64       Shift: TShiftState; X, Y: Single);
  65     procedure FormMouseUp(Sender: TObject; Button: TMouseButton;
  66       Shift: TShiftState; X, Y: Single);
  67     procedure FormMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Single);
  68     procedure Button12Click(Sender: TObject);
  69   private
  70     FGestureOrigin: TPointF;
  71     FGestureInProgress: Boolean;
  72     MySize: Extended;
  73     MyRect: TRectF;
  74     Downed: Boolean;
  75     St, Gt: TPointF;
  76     Angle: Single;
  77     procedure TrimImage;
  78     function CalMyRect(Size: Extended): TRectF;
  79     { private \90é\8c¾ }
  80     procedure ShowToolbar(AShow: Boolean);
  81   public
  82     { public \90é\8c¾ }
  83   end;
  84
  85 var
  86   Form1: TForm1;
  87
  88 implementation
  89
  90 {$R *.fmx}
  91
  92 procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word; var KeyChar: Char;
  93   Shift: TShiftState);
  94 begin
  95   if Key = vkEscape then
  96     ShowToolbar(not ToolbarPopup.IsOpen);
  97 end;
  98
  99 procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;
 100   Shift: TShiftState; X, Y: Single);
 101 begin
 102   if RadioButton2.IsChecked = true then
 103   begin
 104     Downed := true;
 105     St := PointF(X, Y);
 106   end;
 107 end;
 108
 109 procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState;
 110   X, Y: Single);
 111 begin
 112   if (RadioButton2.IsChecked = true) and (Downed = true) then
 113   begin
 114     Gt := PointF(X, Y);
 115     Invalidate;
 116   end;
 117 end;
 118
 119 procedure TForm1.FormMouseUp(Sender: TObject; Button: TMouseButton;
 120   Shift: TShiftState; X, Y: Single);
 121 var
 122   i: Single;
 123 begin
 124   if RadioButton2.IsChecked = true then
 125   begin
 126     Downed := false;
 127     if St.X <> X then
 128     begin
 129       if X > St.X then
 130         i := -GradToDeg(50 * (Y - St.Y) / (X - St.X))
 131       else
 132         i := -GradToDeg(50 * (St.Y - Y) / (St.X - X));
 133       ImageControl1.Bitmap.Rotate(i);
 134       Angle := Angle + i;
 135     end;
 136     Invalidate;
 137   end;
 138 end;
 139
 140 procedure TForm1.FormPaint(Sender: TObject; Canvas: TCanvas;
 141   const ARect: TRectF);
 142 var
 143   s, t: TRectF;
 144   i, j: Extended;
 145 begin
 146   if ImageControl1.Bitmap.IsEmpty = true then
 147     Exit;
 148   if MyRect.Width > 500 then
 149   begin
 150     if MyRect.Width > ImageControl1.Bitmap.Width + 200 then
 151     begin
 152       i := Floor(ImageControl1.Bitmap.Width / 127);
 153       SpinBox3.Value := i;
 154       MyRect := CalMyRect(i);
 155     end;
 156     if (MyRect.Width + 500 > ImageControl1.Bitmap.Width) or
 157       (MyRect.Height + 500 > ImageControl1.Bitmap.Height) then
 158       Canvas.FillRect(RectF(0, 0, 2 * 350, 2 * 350), 0, 0, [], 1);
 159     i := MyRect.Left;
 160     j := MyRect.Top;
 161     s := RectF(0, 0, 350, 350);
 162     t := RectF(i - 250, j - 250, i + 100, j + 100);
 163     Canvas.DrawBitmap(ImageControl1.Bitmap, t, s, 1, true);
 164     i := MyRect.Right;
 165     s := RectF(350, 0, 350 * 2, 350);
 166     t := RectF(i - 100, j - 250, i + 250, j + 100);
 167     Canvas.DrawBitmap(ImageControl1.Bitmap, t, s, 1, true);
 168     i := MyRect.Left;
 169     j := MyRect.Bottom;
 170     s := RectF(0, 350, 350, 350 * 2);
 171     t := RectF(i - 250, j - 100, i + 100, j + 250);
 172     Canvas.DrawBitmap(ImageControl1.Bitmap, t, s, 1, true);
 173     i := MyRect.Right;
 174     s := RectF(350, 350, 350 * 2, 350 * 2);
 175     t := RectF(i - 100, j - 100, i + 250, j + 250);
 176     Canvas.DrawBitmap(ImageControl1.Bitmap, t, s, 1, true);
 177     Canvas.DrawDashRect(RectF(250, 250, 450, 450), 0, 0, [], 1,
 178       TAlphaColors.Black);
 179   end
 180   else
 181   begin
 182     i := (ImageControl1.Bitmap.Width - 2 * 350) / 2;
 183     j := (ImageControl1.Bitmap.Height - 2 * 350) / 2;
 184     s := RectF(i, j, i + 2 * 350, j + 2 * 350);
 185     Canvas.DrawBitmap(ImageControl1.Bitmap, s,
 186       RectF(0, 0, 2 * 350, 2 * 350), 1, true);
 187     i := (2 * 350 - MyRect.Width) / 2;
 188     j := (2 * 350 - MyRect.Height) / 2;
 189     Canvas.DrawDashRect(RectF(i, j, 2 * 350 - i, 2 * 350 - j), 0, 0, [], 1,
 190       TAlphaColors.Black);
 191   end;
 192   if (RadioButton2.IsChecked = true) and (Downed = true) then
 193     Canvas.DrawLine(St, Gt, 0.5);
 194 end;
 195
 196 procedure TForm1.ListBox1Change(Sender: TObject);
 197 var
 198   s: string;
 199 begin
 200   s := ListBox1.Items[ListBox1.ItemIndex];
 201   Button12Click(Sender);
 202   ImageControl1.Bitmap.LoadFromFile(s);
 203   Caption := s;
 204   MyRect := CalMyRect(SpinBox3.Value);
 205   Invalidate;
 206 end;
 207
 208 procedure TForm1.ToolbarCloseButtonClick(Sender: TObject);
 209 begin
 210   Application.Terminate;
 211 end;
 212
 213 procedure TForm1.TrimImage;
 214 var
 215   s: TBitmap;
 216   t: TRect;
 217 begin
 218   t.Left:=Floor(MyRect.Left);
 219   t.Right:=Floor(MyRect.Right);
 220   t.Top:=Floor(MyRect.Top);
 221   t.Bottom:=Floor(MyRect.Bottom);
 222   s:=TBitmap.Create;
 223   try
 224     s.Width:=t.Width;
 225     s.Height:=t.Height;
 226     s.CopyFromBitmap(ImageControl1.Bitmap,t,0,0);
 227     s.SaveToFile(Label3.Text + '\' + ExtractFileName(ListBox1.Items[ListBox1.ItemIndex]));
 228   finally
 229     s.Free;
 230   end;
 231 end;
 232
 233 procedure TForm1.Button11Click(Sender: TObject);
 234 begin
 235   Close;
 236 end;
 237
 238 procedure TForm1.Button12Click(Sender: TObject);
 239 begin
 240   ImageControl1.Bitmap.Rotate(-Angle);
 241   Angle := 0;
 242   if Sender = Button12 then
 243     Invalidate;
 244 end;
 245
 246 procedure TForm1.Button1Click(Sender: TObject);
 247 begin
 248   if ListBox1.ItemIndex > -1 then
 249   begin
 250     if (Sender = Button1) and (DirectoryExists(Label3.Text) = false) then
 251     begin
 252       Button9Click(Sender);
 253       if DirectoryExists(Label3.Text) = false then
 254         Exit;
 255     end;
 256     if Sender = Button1 then
 257       if (CheckBox1.IsChecked = false) or
 258         (FileExists(Label3.Text + '\' + ExtractFileName(ListBox1.Items
 259         [ListBox1.ItemIndex])) = false) then
 260         TrimImage
 261       else if MessageDlg('Assign File ?', TMsgDlgType.mtConfirmation,
 262         mbOKCancel, 0) = mrOK then
 263         TrimImage;
 264     if ListBox1.ItemIndex < ListBox1.Items.Count - 1 then
 265       ListBox1.ItemIndex := ListBox1.ItemIndex + 1;
 266   end;
 267 end;
 268
 269 procedure TForm1.Button3Click(Sender: TObject);
 270 begin
 271   if OpenDialog1.Execute = true then
 272   begin
 273     ListBox1.Items.Assign(OpenDialog1.Files);
 274     if ListBox1.Items.Count > 0 then
 275       ListBox1.ItemIndex := 0;
 276   end;
 277 end;
 278
 279 procedure TForm1.Button4Click(Sender: TObject);
 280 var
 281   i: Single;
 282 begin
 283   if Sender = Button4 then
 284     i := SpinBox1.Value
 285   else
 286     i := -SpinBox1.Value;
 287   MyRect.Top := MyRect.Top - i;
 288   MyRect.Bottom := MyRect.Bottom - i;
 289   Invalidate;
 290 end;
 291
 292 procedure TForm1.Button7Click(Sender: TObject);
 293 var
 294   i: Single;
 295 begin
 296   if Sender = Button7 then
 297     i := SpinBox1.Value
 298   else
 299     i := -SpinBox1.Value;
 300   MyRect.Left := MyRect.Left - i;
 301   MyRect.Right := MyRect.Right - i;
 302   Invalidate;
 303 end;
 304
 305 procedure TForm1.Button8Click(Sender: TObject);
 306 var
 307   i: Extended;
 308 begin
 309   if ImageControl1.Bitmap.IsEmpty = true then
 310     Exit;
 311   MyRect := CalMyRect(20);
 312   if MyRect.Width > ImageControl1.Bitmap.Width + 200 then
 313   begin
 314     i := ImageControl1.Bitmap.Width / 127;
 315     if i < 1 then
 316       MySize := 1
 317     else
 318       MySize := Floor(i);
 319     SpinBox3.Value := MySize;
 320     MyRect := CalMyRect(MySize);
 321   end
 322   else
 323   begin
 324     MySize := 20;
 325     SpinBox3.Value := 20;
 326   end;
 327   Invalidate;
 328 end;
 329
 330 procedure TForm1.Button9Click(Sender: TObject);
 331 var
 332   s, t: string;
 333 begin
 334   GetDir(0, t);
 335   if SelectDirectory('Save Directory', t, s) = true then
 336   begin
 337     Label3.Text := s;
 338   end;
 339   if DirectoryExists(s) = false then
 340     Showmessage('\8aJ\82¯\82È\82¢\83f\83B\83\8c\83N\83g\83\8a\82ð\8eg\97p\82µ\82Ä\82¢\82Ü\82·');
 341 end;
 342
 343 function TForm1.CalMyRect(Size: Extended): TRectF;
 344 var
 345   i, j, m, n: Extended;
 346 const
 347   a = 127;
 348   b = 89;
 349 begin
 350   i := Size * a;
 351   j := Size * b;
 352   m := (ImageControl1.Bitmap.Width - i) / 2;
 353   n := (ImageControl1.Bitmap.Height - j) / 2;
 354   result := RectF(m, n, m + i, n + j);
 355 end;
 356
 357 procedure TForm1.FormGesture(Sender: TObject;
 358   const EventInfo: TGestureEventInfo; var Handled: Boolean);
 359 var
 360   DX, DY: Single;
 361 begin
 362   if EventInfo.GestureID = igiPan then
 363   begin
 364     if (TInteractiveGestureFlag.gfBegin in EventInfo.Flags) and
 365       ((Sender = ToolbarPopup) or (EventInfo.Location.Y > (ClientHeight - 70)))
 366     then
 367     begin
 368       FGestureOrigin := EventInfo.Location;
 369       FGestureInProgress := true;
 370     end;
 371
 372     if FGestureInProgress and (TInteractiveGestureFlag.gfEnd in EventInfo.Flags)
 373     then
 374     begin
 375       FGestureInProgress := false;
 376       DX := EventInfo.Location.X - FGestureOrigin.X;
 377       DY := EventInfo.Location.Y - FGestureOrigin.Y;
 378       if (Abs(DY) > Abs(DX)) then
 379         ShowToolbar(DY < 0);
 380     end;
 381   end
 382 end;
 383
 384 procedure TForm1.ShowToolbar(AShow: Boolean);
 385 begin
 386   ToolbarPopup.Width := ClientWidth;
 387   ToolbarPopup.PlacementRectangle.Rect :=
 388     TRectF.Create(0, ClientHeight - ToolbarPopup.Height, ClientWidth - 1,
 389     ClientHeight - 1);
 390   ToolbarPopupAnimation.StartValue := ToolbarPopup.Height;
 391   ToolbarPopupAnimation.StopValue := 0;
 392
 393   ToolbarPopup.IsOpen := AShow;
 394 end;
 395
 396 procedure TForm1.SpinBox3Change(Sender: TObject);
 397 begin
 398   if ((SpinBox3.Value > MySize) and (ImageControl1.Width > MyRect.Width)) or
 399     (SpinBox3.Value < MySize) then
 400   begin
 401     MySize := SpinBox3.Value;
 402     MyRect := CalMyRect(SpinBox3.Value);
 403   end
 404   else
 405   begin
 406     MySize := SpinBox3.Value;
 407     MyRect := CalMyRect(MySize);
 408   end;
 409   Invalidate;
 410 end;
 411
 412 end.