/examples/shapedcontrols/unit1.pas

http://github.com/graemeg/lazarus · Pascal · 73 lines · 53 code · 15 blank · 5 comment · 0 complexity · c637130e3cabd678096b68886805f0d2 MD5 · raw file

  1. unit Unit1;
  2. {$mode objfpc}{$H+}
  3. interface
  4. uses
  5. Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs, StdCtrls,
  6. ExtCtrls;
  7. type
  8. { TForm1 }
  9. TForm1 = class(TForm)
  10. Button1: TButton;
  11. procedure Button1Click(Sender: TObject);
  12. procedure FormCreate(Sender: TObject);
  13. private
  14. { private declarations }
  15. public
  16. procedure ShapeControl(AControl: TWinControl);
  17. end;
  18. var
  19. Form1: TForm1;
  20. implementation
  21. {$R unit1.lfm}
  22. { TForm1 }
  23. procedure TForm1.Button1Click(Sender: TObject);
  24. begin
  25. ShapeControl(Self);
  26. end;
  27. procedure TForm1.FormCreate(Sender: TObject);
  28. begin
  29. Button1.Handle;
  30. ShapeControl(Button1);
  31. end;
  32. procedure TForm1.ShapeControl(AControl: TWinControl);
  33. var
  34. ABitmap: TBitmap;
  35. Points: array of TPoint;
  36. begin
  37. ABitmap := TBitmap.Create;
  38. ABitmap.Monochrome := True;
  39. ABitmap.Width := AControl.Width;
  40. ABitmap.Height := AControl.Height;
  41. SetLength(Points, 6);
  42. Points[0] := Point(0, ABitmap.Height div 2);
  43. Points[1] := Point(10, 0);
  44. Points[2] := Point(ABitmap.Width - 10, 0);
  45. Points[3] := Point(ABitmap.Width, ABitmap.Height div 2);
  46. Points[4] := Point(ABitmap.Width - 10, ABitmap.Height);
  47. Points[5] := Point(10, ABitmap.Height);
  48. with ABitmap.Canvas do
  49. begin
  50. Brush.Color := clBlack; // transparent color
  51. FillRect(0, 0, ABitmap.Width, ABitmap.Height);
  52. Brush.Color := clWhite; // mask color
  53. Polygon(Points);
  54. end;
  55. AControl.SetShape(ABitmap);
  56. ABitmap.Free;
  57. end;
  58. end.