home *** CD-ROM | disk | FTP | other *** search
/ Chip 2001 September / Chip_2001-09_cd1.bin / zkuste / delphi / kolekce / d56 / RMCTL.ZIP / rmCheckbox.pas < prev    next >
Pascal/Delphi Source File  |  2001-06-22  |  11KB  |  404 lines
  1. {================================================================================
  2. Copyright (C) 1997-2001 Mills Enterprise
  3.  
  4. Unit     : rmCheckBox
  5. Purpose  : Simple Replacement for the MSCheckbox to allow for centering the Box.
  6. Date     : 05-08-2001
  7. Author   : Ryan J. Mills
  8. Version  : 1.80
  9. ================================================================================}
  10.  
  11. unit rmCheckbox;
  12.  
  13. interface
  14.  
  15. {$I CompilerDefines.INC}
  16.  
  17. uses Windows, Messages, Classes, Controls, Forms, Graphics;
  18.  
  19. type
  20.   TCBXAlignment = (cbxLeft, cbxRight, cbxCentered);
  21.  
  22.   TrmCustomCheckBox = class(TCustomControl)
  23.   private
  24.     FChecked: Boolean;
  25.     FMouseDown : boolean;
  26.     fKeyDown : boolean;
  27.     fMouseInControl : boolean;
  28.     fCBXAlignment: TCBXAlignment;
  29.     fFlat: Boolean;
  30.     fShowFocusRect: Boolean;
  31.     fWantTabs: boolean;
  32.     fWantArrows: boolean;
  33.     procedure WMLButtonUp(var Message: TWMLButtonUp); message WM_LBUTTONUP;
  34.     procedure CMDialogChar(var Message: TCMDialogChar); message CM_DIALOGCHAR;
  35.     procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
  36.     procedure CMTextChanged(var Message: TMessage); message CM_TEXTCHANGED;
  37.     procedure CMFocusChanged(var MSG:TMessage); message CM_FOCUSCHANGED;
  38.     procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE;
  39.     procedure WMEraseBkgnd(var message: TMessage); message WM_ERASEBKGND;
  40.     procedure WMGetDlgCode(var Message: TWMGetDlgCode); message WM_GETDLGCODE;
  41.  
  42.     procedure SetChecked(Value: Boolean);
  43.     procedure SetCBXAlignment(const Value: TCBXAlignment);
  44.     function CaptionRect:TRect;
  45.     function CBXRect:TRect;
  46.     procedure SetFlat(const Value: Boolean);
  47.     procedure SetShowFocusRect(const Value: Boolean);
  48.   protected
  49.     procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override;
  50.     procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
  51.     procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
  52.     procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
  53.  
  54.     procedure KeyDown(var Key: Word; Shift: TShiftState); override;
  55.     procedure KeyUp(var Key: Word; Shift: TShiftState); override;
  56.  
  57.     procedure PaintCheck(Rect:TRect); virtual;
  58.     procedure Paint; override;
  59.  
  60.     procedure Click; override;
  61.  
  62.     property Checked: Boolean read FChecked write SetChecked default False;
  63.     property CBXAlignment : TCBXAlignment read fCBXAlignment write SetCBXAlignment default cbxLeft;
  64.     property Flat: Boolean read fFlat write SetFlat default false;
  65.     property ShowFocusRect : boolean read fShowFocusRect write SetShowFocusRect default true;
  66.  
  67.     property IsMouseDown:Boolean read fMouseDown;
  68.     property IsMouseInControl:boolean read fMouseInControl;
  69.     property IsKeyDown:boolean read fKeyDown;
  70.     property WantTabs:boolean read fWantTabs write fWantTabs default false;
  71.     property WantArrows:boolean read fWantArrows write fWantArrows default false;
  72.   public
  73.     constructor Create(AOwner: TComponent); override;
  74.   end;
  75.  
  76.   TrmCheckBox = class(TrmCustomCheckBox)
  77.   published
  78.     property Action;
  79.     property Anchors;
  80.     property BiDiMode;
  81.     property Constraints;
  82.     property CBXAlignment;
  83.     property Checked;
  84.     property Caption;
  85.     property Enabled;
  86.     property Font;
  87.     property Flat;
  88.     property ParentColor;
  89.     property ParentFont;
  90.     property ParentShowHint;
  91.     property ParentBiDiMode;
  92.     property PopupMenu;
  93.     property ShowFocusRect;
  94.     property ShowHint;
  95.     property TabOrder;
  96.     property TabStop;
  97.     property Visible;
  98.     property OnClick;
  99.     property OnDblClick;
  100.     property OnMouseDown;
  101.     property OnMouseMove;
  102.     property OnMouseUp;
  103.   end;
  104.  
  105. implementation
  106.  
  107. uses imglist, Actnlist, rmLibrary;
  108.  
  109. { TrmCustomCheckBox }
  110.  
  111. constructor TrmCustomCheckBox.Create(AOwner: TComponent);
  112. begin
  113.   inherited Create(AOwner);
  114.   SetBounds(0, 0, 90, 17);
  115.   ControlStyle := [csClickEvents, csCaptureMouse, csDoubleClicks, csSetCaption];
  116.   ParentFont := True;
  117.   Color := clBtnFace;
  118.   fCBXAlignment := cbxLeft;
  119.   fMouseInControl := false;
  120.   FChecked := false;
  121.   fFlat := false;
  122.   fShowFocusRect := true;
  123.   FKeyDown := false;
  124.   FMouseDown := false;
  125.   fWantTabs := false;
  126.   fWantArrows := false;
  127.   TabStop := true;
  128. end;
  129.  
  130. procedure TrmCustomCheckBox.Paint;
  131. var
  132.    wRect : TRect;
  133.    wFlags : integer;
  134. begin
  135.    Canvas.brush.color := color;
  136.    Canvas.Font := font;
  137.    Canvas.FillRect(clientrect);
  138.  
  139.    wFlags := dt_VCenter or DT_SingleLine;
  140.  
  141.    case fCBXAlignment of
  142.       cbxLeft: wFlags := wFlags or dt_left;
  143.       cbxRight: wFlags := wFlags or dt_right;
  144.       cbxCentered: wFlags := wFlags or DT_CENTER;
  145.    end;
  146.  
  147.    PaintCheck(CBXRect);
  148.  
  149.    if fCBXAlignment <> cbxCentered then
  150.    begin
  151.       wRect := CaptionRect;
  152.       DrawText(Canvas.Handle, PChar(Caption), length(caption), wRect, wFlags);
  153.       if Focused and fShowFocusRect then
  154.       begin
  155.          inflaterect(wRect, 2, 2);
  156.          Canvas.DrawFocusRect(wRect);
  157.       end;
  158.    end
  159.    else
  160.    begin
  161.       if Focused and fShowFocusRect then
  162.       begin
  163.          wRect := CBXRect;
  164.          InflateRect(wRect, 2, 2);
  165.          Canvas.DrawFocusRect(wRect);
  166.       end;
  167.    end;
  168. end;
  169.  
  170. procedure TrmCustomCheckBox.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
  171. var
  172.    wRect : TRect;
  173. begin
  174.   Inherited;
  175.   if canfocus then
  176.      SetFocus;
  177.  
  178.   UnionRect(wRect, CaptionRect, CBXRect);
  179.   if (Button = mbLeft) and Enabled and ptinrect(wRect, point(x,y)) then
  180.   begin
  181.  
  182.      FMouseDown := true;
  183.      invalidate;
  184.   end;
  185. end;
  186.  
  187. procedure TrmCustomCheckBox.SetChecked(Value: Boolean);
  188. begin
  189.   if Value <> FChecked then
  190.   begin
  191.     FChecked := Value;
  192.     Invalidate;
  193.   end;
  194. end;
  195.  
  196. procedure TrmCustomCheckBox.CMDialogChar(var Message: TCMDialogChar);
  197. begin
  198.   with Message do
  199.     if IsAccel(CharCode, Caption) and Enabled and Visible and
  200.       (Parent <> nil) and Parent.Showing then
  201.     begin
  202.       Click;
  203.       Result := 1;
  204.     end else
  205.       inherited;
  206. end;
  207.     
  208. procedure TrmCustomCheckBox.CMFontChanged(var Message: TMessage);
  209. begin
  210.   Invalidate;
  211. end;
  212.     
  213. procedure TrmCustomCheckBox.CMTextChanged(var Message: TMessage);
  214. begin
  215.   Invalidate;
  216. end;
  217.     
  218. procedure TrmCustomCheckBox.ActionChange(Sender: TObject; CheckDefaults: Boolean);
  219. begin
  220.   inherited ActionChange(Sender, CheckDefaults);
  221.   if Sender is TCustomAction then
  222.     with TCustomAction(Sender) do
  223.     begin
  224.        Invalidate;
  225.     end;
  226. end;
  227.  
  228. procedure TrmCustomCheckBox.PaintCheck(Rect:TRect);
  229. var
  230.    wFlags : integer;
  231. begin
  232.    wFlags := DFCS_BUTTONCHECK;
  233.  
  234.    if FFlat then
  235.       wFlags := wFlags or DFCS_FLAT;
  236.  
  237.    if FChecked then
  238.       wFlags := wFlags or DFCS_CHECKED;
  239.  
  240.    if (not Enabled) then
  241.       wFlags := wFlags or DFCS_INACTIVE;
  242.  
  243.    if (fMouseInControl and FMouseDown) or (fKeyDown) then
  244.       wFlags := wFlags or DFCS_PUSHED;
  245.  
  246.    DrawFrameControl(canvas.handle, Rect, DFC_BUTTON, wFlags);
  247. end;
  248.  
  249. procedure TrmCustomCheckBox.SetCBXAlignment(const Value: TCBXAlignment);
  250. begin
  251.   if fCBXAlignment <> Value then
  252.   begin
  253.     fCBXAlignment := Value;
  254.     invalidate;
  255.   end;
  256. end;
  257.  
  258. procedure TrmCustomCheckBox.cmFocusChanged(var MSG: TMessage);
  259. begin
  260.    inherited;
  261.    fKeyDown := false;
  262.    FMouseDown := False;
  263.    invalidate;  
  264. end;
  265.  
  266. procedure TrmCustomCheckBox.MouseUp(Button: TMouseButton;
  267.   Shift: TShiftState; X, Y: Integer);
  268. var
  269.    wMD: boolean;
  270.    wRect : TRect;
  271. begin
  272.   inherited;
  273.  
  274.   UnionRect(wRect, CaptionRect, CBXRect);
  275.   wMD := fMouseDown;
  276.   fMouseDown := false;
  277.   if wMD and enabled and (ptinrect(wRect, point(x,y))) then
  278.   begin
  279.      FChecked := not fChecked;
  280.      Invalidate;
  281.      Click;
  282.   end;
  283. end;
  284.  
  285. procedure TrmCustomCheckBox.MouseMove(Shift: TShiftState; X, Y: Integer);
  286. var
  287.    fLastCheck : boolean;
  288. begin
  289.   inherited;
  290.   fLastCheck := fMouseInControl;
  291.   fMouseInControl := PTInRect(ClientRect, point(x,y));
  292.   if fLastCheck <> fMouseInControl then
  293.      Invalidate;
  294. end;
  295.  
  296. procedure TrmCustomCheckBox.KeyDown(var Key: Word; Shift: TShiftState);
  297. begin
  298.   inherited;
  299.   if (key = vk_space) and (Shift = []) then
  300.   begin
  301.      fKeyDown := true;
  302.      invalidate;
  303.   end;
  304. end;
  305.  
  306. procedure TrmCustomCheckBox.KeyUp(var Key: Word; Shift: TShiftState);
  307. var
  308.    wKD: boolean;
  309. begin
  310.   inherited;
  311.   wKD := fKeyDown;
  312.   fKeyDown := false;
  313.   if wKD and (key = vk_space) then
  314.   begin
  315.      FChecked := not fChecked;
  316.      Invalidate;
  317.      click;
  318.   end;
  319. end;
  320.  
  321. procedure TrmCustomCheckBox.WMLButtonUp(var Message: TWMLButtonUp);
  322. var
  323.    wClicked : boolean;
  324. begin
  325.    wClicked := csClicked in ControlState;
  326.    if wClicked then
  327.       ControlState := ControlState - [csClicked];
  328.  
  329.    Inherited;
  330.  
  331.    if wClicked then
  332.       ControlState := ControlState + [csClicked];
  333. end;
  334.  
  335. procedure TrmCustomCheckBox.Click;
  336. begin
  337.   inherited;
  338.   Invalidate;
  339. end;
  340.  
  341. function TrmCustomCheckBox.CaptionRect: TRect;
  342. begin
  343.    case fCBXAlignment of
  344.       cbxLeft:
  345.          begin
  346.             result := rect(0, 0, Canvas.textwidth(Caption), Canvas.Textheight(caption));
  347.             offsetRect(result, RectWidth(CBXRect)+7, (height div 2) - (RectHeight(result) div 2));
  348.          end;
  349.       cbxRight:
  350.          begin
  351.             result := rect(width-Canvas.textwidth(Caption), 0, width, Canvas.Textheight(caption));
  352.             offsetRect(result, -(RectWidth(CBXRect)+7), (height div 2) - (RectHeight(result) div 2));
  353.          end;
  354.       cbxCentered: result := CBXRect;
  355.    end;
  356. end;
  357.  
  358. function TrmCustomCheckBox.CBXRect: TRect;
  359. begin
  360.    result := Rect(0, 0, 13, 13);
  361.    case fCBXAlignment of
  362.       cbxLeft: offsetRect(result, 3, (height div 2) - (RectHeight(result) div 2));
  363.       cbxRight: offsetRect(result, width - (RectWidth(result)+3), (height div 2) - (RectHeight(result) div 2));
  364.       cbxCentered: offsetRect(result, (width div 2) - (rectWidth(result) div 2), (height div 2) - (RectHeight(result) div 2));
  365.    end;
  366. end;
  367.  
  368. procedure TrmCustomCheckBox.CMMouseLeave(var Message: TMessage);
  369. begin
  370.    inherited;
  371.    invalidate;
  372. end;
  373.  
  374. procedure TrmCustomCheckBox.SetFlat(const Value: Boolean);
  375. begin
  376.   fFlat := Value;
  377.   invalidate;
  378. end;
  379.  
  380. procedure TrmCustomCheckBox.SetShowFocusRect(const Value: Boolean);
  381. begin
  382.   fShowFocusRect := Value;
  383.   invalidate;
  384. end;
  385.  
  386. procedure TrmCustomCheckBox.WMEraseBkgnd(var message: TMessage);
  387. begin
  388.    message.result := 0;   
  389. end;
  390.  
  391. procedure TrmCustomCheckBox.WMGetDlgCode(var Message: TWMGetDlgCode);
  392. begin
  393.    inherited;
  394.  
  395.    if fWantTabs then
  396.       Message.Result := Message.Result or DLGC_WANTTAB;
  397.  
  398.    if fWantArrows then
  399.       Message.Result := Message.Result or DLGC_WANTARROWS;
  400.  
  401. end;
  402.  
  403. end.
  404.