www.pudn.com > virdisk_source.rar > TFlatCheckBoxUnit.pas

unit TFlatCheckBoxUnit; 
 
interface 
 
{$I Version.inc} 
 
uses 
  Windows, Messages, Classes, Graphics, Controls, Forms, ExtCtrls, FlatUtilitys; 
 
type 
  TFlatCheckBox = class(TCustomControl) 
  private 
    FUseAdvColors: Boolean; 
    FAdvColorFocused: TAdvColors; 
    FAdvColorDown: TAdvColors; 
    FAdvColorBorder: TAdvColors; 
    FMouseInControl: Boolean; 
    MouseIsDown: Boolean; 
    Focused: Boolean; 
    FLayout: TCheckBoxLayout; 
    FChecked: Boolean; 
    FFocusedColor: TColor; 
    FDownColor: TColor; 
    FCheckColor: TColor; 
    FBorderColor: TColor; 
    procedure SetColors (Index: Integer; Value: TColor); 
    procedure SetAdvColors (Index: Integer; Value: TAdvColors); 
    procedure SetUseAdvColors (Value: Boolean); 
    procedure SetLayout (Value: TCheckBoxLayout); 
    procedure SetChecked (Value: Boolean); 
    procedure CMEnabledChanged (var Message: TMessage); message CM_ENABLEDCHANGED; 
    procedure CMTextChanged (var Message: TWmNoParams); message CM_TEXTCHANGED; 
    procedure CMDialogChar (var Message: TCMDialogChar); message CM_DIALOGCHAR; 
    procedure CNCommand (var Message: TWMCommand); message CN_COMMAND; 
    procedure WMSetFocus (var Message: TWMSetFocus); message WM_SETFOCUS; 
    procedure WMKillFocus (var Message: TWMKillFocus); message WM_KILLFOCUS; 
    procedure CMSysColorChange (var Message: TMessage); message CM_SYSCOLORCHANGE; 
    procedure CMParentColorChanged (var Message: TWMNoParams); message CM_PARENTCOLORCHANGED; 
    procedure RemoveMouseTimer; 
    procedure MouseTimerHandler (Sender: TObject); 
    procedure CMDesignHitTest (var Message: TCMDesignHitTest); message CM_DESIGNHITTEST; 
  protected 
    procedure CalcAdvColors; 
    procedure DoEnter; override; 
    procedure DoExit; override; 
    procedure MouseDown (Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; 
    procedure MouseUp (Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; 
    procedure MouseMove (Shift: TShiftState; X, Y: Integer); override; 
    procedure CreateWnd; override; 
    procedure DrawCheckRect; 
    procedure DrawCheckText; 
    procedure Paint; override; 
  public 
    constructor Create (AOwner: TComponent); override; 
    destructor Destroy; override; 
    procedure MouseEnter; 
    procedure MouseLeave; 
  published 
    property Caption; 
    property Checked: Boolean read FChecked write SetChecked default false; 
    property Color default $00E1EAEB; 
    property ColorFocused: TColor index 0 read FFocusedColor write SetColors default clWhite; 
    property ColorDown: TColor index 1 read FDownColor write SetColors default $00C5D6D9; 
    property ColorCheck: TColor index 2 read FCheckColor write SetColors default clBlack; 
    property ColorBorder: TColor index 3 read FBorderColor write SetColors default $008396A0; 
    property AdvColorFocused: TAdvColors index 0 read FAdvColorFocused write SetAdvColors default 10; 
    property AdvColorDown: TAdvColors index 1 read FAdvColorDown write SetAdvColors default 10; 
    property AdvColorBorder: TAdvColors index 2 read FAdvColorBorder write SetAdvColors default 50; 
    property UseAdvColors: Boolean read FUseAdvColors write SetUseAdvColors default false; 
    property Enabled; 
    property Font; 
    property Layout: TCheckBoxLayout read FLayout write SetLayout default checkBoxLeft; 
    property ParentColor; 
    property ParentFont; 
    property ShowHint; 
    property TabOrder; 
    property TabStop; 
    property Visible; 
    property OnClick; 
    property OnDragDrop; 
    property OnDragOver; 
    property OnEndDrag; 
    property OnEnter; 
    property OnExit; 
    property OnKeyDown; 
    property OnKeyPress; 
    property OnKeyUp; 
    property OnMouseDown; 
    property OnMouseMove; 
    property OnMouseUp; 
   {$IFDEF D4CB4} 
    property Anchors; 
    property BiDiMode; 
    property Constraints; 
    property DragKind; 
    property ParentBiDiMode; 
    property OnEndDock; 
    property OnStartDock; 
   {$ENDIF} 
  end; 
 
var 
  MouseInControl: TFlatCheckBox = nil; 
 
implementation 
 
var 
  MouseTimer: TTimer = nil; 
  ControlCounter: Integer = 0; 
 
procedure TFlatCheckBox.CMDesignHitTest(var Message: TCMDesignHitTest); 
begin 
  case FLayout of 
    checkboxLeft: 
      if PtInRect(Rect(ClientRect.Left + 1, ClientRect.Top + 3, ClientRect.Left + 12, ClientRect.Top + 14), Point(message.XPos, message.YPos)) then 
        Message.Result := 1 
      else 
        Message.Result := 0; 
    checkboxRight: 
      if PtInRect(Rect(ClientRect.Right - 12, ClientRect.Top + 3, ClientRect.Right - 1, ClientRect.Top + 14), Point(message.XPos, message.YPos)) then 
        Message.Result := 1 
      else 
        Message.Result := 0; 
  end; 
end; 
 
constructor TFlatCheckBox.Create (AOwner: TComponent); 
begin 
  inherited Create(AOwner); 
  if MouseTimer = nil then 
  begin 
    MouseTimer := TTimer.Create(nil); 
    MouseTimer.Enabled := False; 
    MouseTimer.Interval := 100; // 10 times a second 
  end; 
  ParentColor := True; 
  ParentFont := True; 
  FFocusedColor := clWhite; 
  FDownColor := $00C5D6D9; 
  FCheckColor := clBlack; 
  FBorderColor := $008396A0; 
  FLayout := checkboxLeft; 
  TabStop := True; 
  FChecked := false; 
  Enabled := true; 
  Visible := true; 
  SetBounds(0, 0, 121, 17); 
  FUseAdvColors := false; 
  FAdvColorFocused := 10; 
  FAdvColorDown := 10; 
  FAdvColorBorder := 50; 
  Inc(ControlCounter); 
end; 
 
destructor TFlatCheckBox.Destroy; 
begin 
  RemoveMouseTimer; 
  Dec(ControlCounter); 
  if ControlCounter = 0 then 
  begin 
    MouseTimer.Free; 
    MouseTimer := nil; 
  end; 
  inherited; 
end; 
 
procedure TFlatCheckBox.SetColors (Index: Integer; Value: TColor); 
begin 
  case Index of 
    0: FFocusedColor := Value; 
    1: FDownColor := Value; 
    2: FCheckColor := Value; 
    3: FBorderColor := Value; 
  end; 
  Invalidate; 
end; 
 
procedure TFlatCheckBox.CalcAdvColors; 
begin 
  if FUseAdvColors then 
  begin 
    FFocusedColor := CalcAdvancedColor(Color, FFocusedColor, FAdvColorFocused, lighten); 
    FDownColor := CalcAdvancedColor(Color, FDownColor, FAdvColorDown, darken); 
    FBorderColor := CalcAdvancedColor(Color, FBorderColor, FAdvColorBorder, darken); 
  end; 
end; 
 
procedure TFlatCheckBox.SetAdvColors (Index: Integer; Value: TAdvColors); 
begin 
  case Index of 
    0: FAdvColorFocused := Value; 
    1: FAdvColorDown := Value; 
    2: FAdvColorBorder := Value; 
  end; 
  CalcAdvColors; 
  Invalidate; 
end; 
 
procedure TFlatCheckBox.SetUseAdvColors (Value: Boolean); 
begin 
  if Value <> FUseAdvColors then 
  begin 
    FUseAdvColors := Value; 
    ParentColor := Value; 
    CalcAdvColors; 
    Invalidate; 
  end; 
end; 
 
procedure TFlatCheckBox.SetLayout (Value: TCheckBoxLayout); 
begin 
  FLayout := Value; 
  Invalidate; 
end; 
 
procedure TFlatCheckBox.SetChecked (Value: Boolean); 
begin 
  if FChecked <> Value then 
  begin 
    FChecked := Value; 
    Click; 
    DrawCheckRect; 
    if csDesigning in ComponentState then 
      if (GetParentForm(self) <> nil) and (GetParentForm(self).Designer <> nil) then 
        GetParentForm(self).Designer.Modified; 
  end; 
end; 
 
procedure TFlatCheckBox.CMEnabledChanged (var Message: TMessage); 
begin 
  inherited; 
  if not Enabled then 
  begin 
    FMouseInControl := False; 
    MouseIsDown := False; 
    RemoveMouseTimer; 
  end; 
  Invalidate; 
end; 
 
procedure TFlatCheckBox.CMTextChanged (var Message: TWmNoParams); 
begin 
  inherited; 
  Invalidate; 
end; 
 
procedure TFlatCheckBox.MouseEnter; 
begin 
  if Enabled and not FMouseInControl then 
  begin 
    FMouseInControl := True; 
    DrawCheckRect; 
  end; 
end; 
 
procedure TFlatCheckBox.MouseLeave; 
begin 
  if Enabled and FMouseInControl and not MouseIsDown then 
  begin 
    FMouseInControl := False; 
    RemoveMouseTimer; 
    DrawCheckRect; 
  end; 
end; 
 
procedure TFlatCheckBox.CMDialogChar (var Message: TCMDialogChar); 
begin 
  with Message do 
    if IsAccel(Message.CharCode, Caption) and CanFocus then 
    begin 
      SetFocus; 
      if Checked then 
        Checked := False 
      else 
        Checked := True; 
      Result := 1; 
    end 
    else 
      if (CharCode = VK_SPACE) and Focused then 
      begin 
        if Checked then 
          Checked := False 
        else 
          Checked := True; 
      end 
      else 
        inherited; 
end; 
 
procedure TFlatCheckBox.CNCommand (var Message: TWMCommand); 
begin 
  if Message.NotifyCode = BN_CLICKED then Click; 
end; 
 
procedure TFlatCheckBox.WMSetFocus (var Message: TWMSetFocus); 
begin 
  inherited; 
  if Enabled then 
  begin 
    Focused := True; 
    DrawCheckRect; 
  end; 
end; 
 
procedure TFlatCheckBox.WMKillFocus (var Message: TWMKillFocus); 
begin 
  inherited; 
  if Enabled then 
  begin 
    FMouseInControl := False; 
    Focused := False; 
    DrawCheckRect; 
  end; 
end; 
 
procedure TFlatCheckBox.CMSysColorChange (var Message: TMessage); 
begin 
  if FUseAdvColors then 
  begin 
    ParentColor := True; 
    CalcAdvColors; 
  end; 
  Invalidate; 
end; 
 
procedure TFlatCheckBox.CMParentColorChanged (var Message: TWMNoParams); 
begin 
  inherited; 
  if FUseAdvColors then 
  begin 
    ParentColor := True; 
    CalcAdvColors; 
  end; 
  Invalidate; 
end; 
 
procedure TFlatCheckBox.DoEnter; 
begin 
  inherited DoEnter; 
  Focused := True; 
  DrawCheckRect; 
end; 
 
procedure TFlatCheckBox.DoExit; 
begin 
  inherited DoExit; 
  Focused := False; 
  DrawCheckRect; 
end; 
 
procedure TFlatCheckBox.MouseDown (Button: TMouseButton; Shift: TShiftState; X, Y: Integer); 
begin 
  if (Button = mbLeft) and Enabled then 
  begin 
    SetFocus; 
    MouseIsDown := true; 
    DrawCheckRect; 
    inherited MouseDown(Button, Shift, X, Y); 
  end; 
end; 
 
procedure TFlatCheckBox.MouseUp (Button: TMouseButton; Shift: TShiftState; X, Y: Integer); 
begin 
  if (Button = mbLeft) and Enabled then 
  begin 
    MouseIsDown := false; 
    if FMouseInControl then 
      if Checked then 
        Checked := False 
      else 
        Checked := True; 
    DrawCheckRect; 
    inherited MouseUp(Button, Shift, X, Y); 
  end; 
end; 
 
procedure TFlatCheckBox.MouseMove (Shift: TShiftState; X, Y: Integer); 
var 
  P: TPoint; 
begin 
  inherited; 
  // mouse is in control ? 
  P := ClientToScreen(Point(X, Y)); 
  if (MouseInControl <> Self) and (FindDragTarget(P, True) = Self) then 
  begin 
    if Assigned(MouseInControl) then 
      MouseInControl.MouseLeave; 
    // the application is active ? 
    if (GetActiveWindow <> 0) then 
    begin 
      if MouseTimer.Enabled then 
        MouseTimer.Enabled := False; 
      MouseInControl := Self; 
      MouseTimer.OnTimer := MouseTimerHandler; 
      MouseTimer.Enabled := True; 
      MouseEnter; 
    end; 
  end; 
end; 
 
procedure TFlatCheckBox.CreateWnd; 
begin 
  inherited CreateWnd; 
  SendMessage(Handle, BM_SETCHECK, Cardinal(FChecked), 0); 
end; 
 
procedure TFlatCheckBox.DrawCheckRect; 
var 
  CheckboxRect: TRect; 
begin 
  case FLayout of 
    checkboxLeft: 
      CheckboxRect := Rect(ClientRect.Left + 1, ClientRect.Top + 3, ClientRect.Left + 12, ClientRect.Top + 14); 
    checkboxRight: 
      CheckboxRect := Rect(ClientRect.Right - 12, ClientRect.Top + 3, ClientRect.Right - 1, ClientRect.Top + 14); 
  end; 
 
  canvas.pen.style := psSolid; 
  canvas.pen.width := 1; 
  // Background 
  if Focused or FMouseInControl then 
    if not MouseIsDown then 
    begin 
      canvas.brush.color := FFocusedColor; 
      canvas.pen.color := FFocusedColor; 
    end 
    else 
    begin 
      canvas.brush.color := FDownColor; 
      canvas.brush.color := FDownColor; 
    end 
  else 
  begin 
    canvas.brush.color := Color; 
    canvas.pen.color := Color; 
  end; 
  canvas.FillRect(CheckboxRect); 
  // Tick 
  if Checked then 
  begin 
    if Enabled then 
      canvas.pen.color := FCheckColor 
    else 
      canvas.pen.color := clBtnShadow; 
    canvas.penpos := Point(CheckboxRect.left+2, CheckboxRect.top+4); 
    canvas.lineto(CheckboxRect.left+6, CheckboxRect.top+8); 
    canvas.penpos := Point(CheckboxRect.left+2, CheckboxRect.top+5); 
    canvas.lineto(CheckboxRect.left+5, CheckboxRect.top+8); 
    canvas.penpos := Point(CheckboxRect.left+2, CheckboxRect.top+6); 
    canvas.lineto(CheckboxRect.left+5, CheckboxRect.top+9); 
    canvas.penpos := Point(CheckboxRect.left+8, CheckboxRect.top+2); 
    canvas.lineto(CheckboxRect.left+4, CheckboxRect.top+6); 
    canvas.penpos := Point(CheckboxRect.left+8, CheckboxRect.top+3); 
    canvas.lineto(CheckboxRect.left+4, CheckboxRect.top+7); 
    canvas.penpos := Point(CheckboxRect.left+8, CheckboxRect.top+4); 
    canvas.lineto(CheckboxRect.left+5, CheckboxRect.top+7); 
  end; 
  // Border 
  canvas.brush.color := FBorderColor; 
  canvas.FrameRect(CheckboxRect); 
end; 
 
procedure TFlatCheckBox.DrawCheckText; 
var 
  TextBounds: TRect; 
  Format: UINT; 
begin 
  Format := DT_WORDBREAK; 
  case FLayout of 
    checkboxLeft: 
    begin 
      TextBounds := Rect(ClientRect.Left + 16, ClientRect.Top + 1, ClientRect.Right - 1, ClientRect.Bottom - 1); 
      Format := Format or DT_LEFT; 
    end; 
    checkboxRight: 
    begin 
      TextBounds := Rect(ClientRect.Left + 1, ClientRect.Top + 1, ClientRect.Right - 16, ClientRect.Bottom - 1); 
      Format := Format or DT_RIGHT; 
    end; 
  end; 
 
  with Canvas do 
  begin 
    Brush.Style := bsClear; 
    Font := Self.Font; 
    if not Enabled then 
    begin 
      OffsetRect(TextBounds, 1, 1); 
      Font.Color := clBtnHighlight; 
      DrawText(Handle, PChar(Caption), Length(Caption), TextBounds, Format); 
      OffsetRect(TextBounds, -1, -1); 
      Font.Color := clBtnShadow; 
      DrawText(Handle, PChar(Caption), Length(Caption), TextBounds, Format); 
    end 
    else 
      DrawText(Handle, PChar(Caption), Length(Caption), TextBounds, Format); 
  end; 
end; 
 
procedure TFlatCheckBox.Paint; 
begin 
  DrawCheckRect; 
  DrawCheckText; 
end; 
 
procedure TFlatCheckBox.MouseTimerHandler (Sender: TObject); 
var 
  P: TPoint; 
begin 
  GetCursorPos (P); 
  if FindDragTarget(P, True) <> Self then 
    MouseLeave; 
end; 
 
procedure TFlatCheckBox.RemoveMouseTimer; 
begin 
  if MouseInControl = Self then 
  begin 
    MouseTimer.Enabled := False; 
    MouseInControl := nil; 
  end; 
end; 
 
end.