home *** CD-ROM | disk | FTP | other *** search
/ PC World Komputer 1998 January / Pcwk0198.iso / Dcomplib / ARROWBTN.LZH / ARROWBTN.PAS
Encoding:
Pascal/Delphi Source File  |  1995-12-27  |  6.9 KB  |  262 lines
  1. unit arrowbtn;
  2.  
  3.  
  4. {********************************************************************
  5.   TArrowButton component for Delphi
  6.   
  7.   Author: Kent Miller  Frederick, MD
  8.   Compuserve: 74113,200
  9.   
  10.   Freeware: Feel free to use and improve
  11.     
  12.     I welcome any comments or suggestions that you may have, however
  13.   I am new to creating components so please be gentle.
  14. *********************************************************************}
  15.   
  16.  
  17. interface
  18.  
  19. uses
  20.   SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  21.   Forms, Dialogs;
  22.  
  23. type
  24.   TButtonDirection = (arwUP, arwRIGHT, arwLEFT, arwDOWN);
  25.  
  26.   TArrowButton = class(TGraphicControl)
  27.   private
  28.     kDirection: TButtonDirection;
  29.     kButtonColor: TColor;
  30.     kButtonDown: boolean;
  31.     kpnts: array[1..3] of TPoint;
  32.     kRgn: HRgn;
  33.  
  34.     procedure SetDirection(value: TButtonDirection);
  35.     procedure SetButtonColor(value: TColor);
  36.     procedure FreeRegion;
  37.   protected
  38.     procedure Paint; override;
  39.     procedure DrawUpArrow;
  40.     procedure DrawRightArrow;
  41.     procedure DrawDownArrow;
  42.     procedure DrawLeftArrow;
  43.     procedure MoveButton; virtual;
  44.     procedure WMLButtonDown(var Message: TWMLButtonDown);
  45.                       message WM_LBUTTONDOWN;
  46.     procedure WMLButtonUp(var Message: TWMLButtonUp);
  47.                       message WM_LBUTTONUP;
  48.   public
  49.     constructor Create(AOwner: TComponent); override;
  50.     destructor Destroy; override;
  51.   published
  52.     property ButtonColor: TColor read kButtonColor write SetButtonColor;
  53.     property Direction: TButtonDirection read kDirection write SetDirection;
  54.     property Enabled;
  55.     property ParentShowHint;
  56.     property ShowHint;
  57.     property Visible;
  58.  
  59.     property OnClick;
  60.   end;
  61.  
  62. procedure Register;
  63.  
  64. implementation
  65.  
  66. const
  67.   { offset from border of control to corner of button }
  68.   S_OFFSET = 3;
  69.  
  70. constructor TArrowButton.Create(AOwner: TComponent);
  71. begin
  72.   inherited Create(AOwner);
  73.   ControlStyle := [csClickEvents, csCaptureMouse];
  74.   Width := 33;
  75.   Height := 33;
  76.   kDirection := arwUP;
  77.   kButtonColor := clTeal;
  78.   kRgn := 0;
  79.   kButtonDown := False;
  80. end;
  81.  
  82. destructor TArrowButton.Destroy;
  83. begin
  84.   if kRgn <> 0 then
  85.     FreeRegion;
  86.   inherited Destroy;
  87. end;
  88.  
  89. procedure TArrowButton.Paint;
  90. begin
  91.   inherited Paint;
  92.   FreeRegion;
  93.   case kDirection of
  94.     arwUP: DrawUpArrow;
  95.     arwRIGHT: DrawRightArrow;
  96.     arwDOWN: DrawDownArrow;
  97.     arwLEFT: DrawLeftArrow;
  98.   end;
  99. end;
  100.  
  101. procedure TArrowButton.DrawUpArrow;
  102. begin
  103.   Canvas.Brush.Color := clBlack;
  104.   Canvas.Pen.Color := clBlack;
  105.   { create border region for button }
  106.   kpnts[1] := Point(Width div 2, S_OFFSET);
  107.   kpnts[2] := Point(Width - S_OFFSET, Height - S_OFFSET);
  108.   kpnts[3] := Point(S_OFFSET, Height - S_OFFSET);
  109.   { save region to capture mouse clicks }
  110.   kRgn := CreatePolygonRgn(kpnts, 3, ALTERNATE);
  111.   { draw black border around button }
  112.   FrameRgn(Canvas.Handle, kRgn, Canvas.Brush.Handle, 2, 2);
  113.   { create region within black border for button }
  114.   Inc(kpnts[1].Y, 3);
  115.   Dec(kpnts[2].X, 4);
  116.   Dec(kpnts[2].Y, 2);
  117.   Inc(kpnts[3].X, 3);
  118.   Dec(kpnts[3].Y, 2);
  119.   Canvas.Brush.Color := kButtonColor;
  120.   { draw button }
  121.   Canvas.Polygon(kpnts);
  122.   MoveButton;
  123. end;
  124.  
  125. procedure TArrowButton.DrawRightArrow;
  126. begin
  127.   Canvas.Brush.Color := clBlack;
  128.   Canvas.Pen.Color := clBlack;
  129.   kpnts[1] := Point(S_OFFSET, S_OFFSET);
  130.   kpnts[2] := Point(Width - S_OFFSET, Height div 2);
  131.   kpnts[3] := Point(S_OFFSET, Height - S_OFFSET);
  132.   kRgn := CreatePolygonRgn(kpnts, 3, ALTERNATE);
  133.   FrameRgn(Canvas.Handle, kRgn, Canvas.Brush.Handle, 2, 2);
  134.   Inc(kpnts[1].X, 2);
  135.   Inc(kpnts[1].Y, 3);
  136.   Dec(kpnts[2].X, 3);
  137.   Inc(kpnts[3].X, 2);
  138.   Dec(kpnts[3].Y, 3);
  139.   Canvas.Brush.Color := kButtonColor;
  140.   Canvas.Polygon(kpnts);
  141.   MoveButton;
  142. end;
  143.  
  144. procedure TArrowButton.DrawDownArrow;
  145. begin
  146.   Canvas.Brush.Color := clBlack;
  147.   Canvas.Pen.Color := clBlack;
  148.   kpnts[1] := Point(Width - S_OFFSET, S_OFFSET);
  149.   kpnts[2] := Point(Width div 2, Height - S_OFFSET);
  150.   kpnts[3] := Point(S_OFFSET, S_OFFSET);
  151.   kRgn := CreatePolygonRgn(kpnts, 3, ALTERNATE);
  152.   FrameRgn(Canvas.Handle, kRgn, Canvas.Brush.Handle, 2, 2);
  153.   Dec(kpnts[1].X, 3);
  154.   Inc(kpnts[1].Y, 2);
  155.   Dec(kpnts[2].Y, 3);
  156.   Inc(kpnts[3].X, 2);
  157.   Inc(kpnts[3].Y, 2);
  158.   Canvas.Brush.Color := kButtonColor;
  159.   Canvas.Polygon(kpnts);
  160.   MoveButton;
  161. end;
  162.  
  163. procedure TArrowButton.DrawLeftArrow;
  164. begin
  165.   Canvas.Brush.Color := clBlack;
  166.   Canvas.Pen.Color := clBlack;
  167.   kpnts[1] := Point(Width - S_OFFSET, S_OFFSET);
  168.   kpnts[2] := Point(Width - S_OFFSET, Height - S_OFFSET);
  169.   kpnts[3] := Point(S_OFFSET, Height div 2);
  170.   kRgn := CreatePolygonRgn(kpnts, 3, ALTERNATE);
  171.   FrameRgn(Canvas.Handle, kRgn, Canvas.Brush.Handle, 2, 2);
  172.   Dec(kpnts[1].X, 2);
  173.   Inc(kpnts[1].Y, 3);
  174.   Dec(kpnts[2].X, 2);
  175.   Dec(kpnts[2].Y, 2);
  176.   Inc(kpnts[3].X, 3);
  177.   Canvas.Brush.Color := kButtonColor;
  178.   Canvas.Polygon(kpnts);
  179.   MoveButton;
  180. end;
  181.  
  182. procedure TArrowButton.MoveButton;
  183. begin
  184.   if not kButtonDown then  { button is in up position }
  185.     with Canvas do
  186.       begin
  187.         { draw lines around button for raised look }
  188.         Pen.Color := clBlack;
  189.         MoveTo(kpnts[1].X, kpnts[1].Y);
  190.         LineTo(kpnts[2].X, kpnts[2].Y);
  191.         MoveTo(kpnts[2].X, kpnts[2].Y);
  192.         LineTo(kpnts[3].X, kpnts[3].Y);
  193.         Pen.Color := clWhite;
  194.         MoveTo(kpnts[1].X, kpnts[1].Y);
  195.         LineTo(kpnts[3].X, kpnts[3].Y);
  196.       end
  197.   else  { button is in down position }
  198.     with Canvas do
  199.       begin
  200.         { draw lines around button for sunken look }
  201.         Pen.Color := clBlack;
  202.         MoveTo(kpnts[1].X, kpnts[1].Y);
  203.         LineTo(kpnts[3].X, kpnts[3].Y);
  204.         Pen.Color := kButtonColor;
  205.         MoveTo(kpnts[1].X, kpnts[1].Y);
  206.         LineTo(kpnts[2].X, kpnts[2].Y);
  207.         MoveTo(kpnts[2].X, kpnts[2].Y);
  208.         LineTo(kpnts[3].X, kpnts[3].Y);
  209.       end;
  210. end;
  211.  
  212. procedure TArrowButton.SetDirection(value: TButtonDirection);
  213. begin
  214.   if value <> kDirection then
  215.     begin
  216.       kDirection := value;
  217.       Invalidate;
  218.     end;
  219. end;
  220.  
  221. procedure TArrowButton.SetButtonColor(value: TColor);
  222. begin
  223.   if value <> kButtonColor then
  224.     begin
  225.       kButtonColor := value;
  226.       Invalidate;
  227.     end;
  228. end;
  229.  
  230. procedure TArrowButton.FreeRegion;
  231. begin
  232.   if kRgn <> 0 then
  233.     DeleteObject(kRgn);
  234.   kRgn := 0;
  235. end;
  236.  
  237. procedure TArrowButton.WMLButtonDown(var Message: TWMLButtonDown);
  238. begin
  239.   { if mouse is clicked on the arrowbutton make it appear sunken }
  240.   if not PtInRegion(kRgn, Message.xPos, Message.yPos) then Exit;
  241.   kButtonDown := True;
  242.   MoveButton;
  243.   inherited;
  244. end;
  245.  
  246. procedure TArrowButton.WMLButtonUp(var Message: TWMLButtonUp);
  247. begin
  248.   { if arrowbutton is down and mouse is released then
  249.     make arrowbutton appear raised }
  250.   if not kButtonDown then Exit;
  251.   kButtonDown := False;
  252.   MoveButton;
  253.   inherited;
  254. end;
  255.  
  256. procedure Register;
  257. begin
  258.   RegisterComponents('Samples', [TArrowButton]);
  259. end;
  260.  
  261. end.
  262.