schecklistbox.pas

AlphaControls是一个Delphi标准控件的集合

unit sCheckListBox;
{$I sDefs.inc}

{$T-,H+,X+}

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, CheckLst, sCommonData, sScrollBar, sAlphaListBox;

type
  TsCheckListBox = class(TsAlphaListBox)
  private
    FAllowGrayed: Boolean;
    FStandardItemHeight: Integer;
    FOnClickCheck: TNotifyEvent;
    FSaveStates: TList;
    procedure ResetItemHeight;
    procedure DrawCheck(R: TRect; AState: TCheckBoxState; AEnabled: Boolean; C : TCanvas);
    procedure SetChecked(Index: Integer; Checked: Boolean);
    function GetChecked(Index: Integer): Boolean;
    procedure SetState(Index: Integer; AState: TCheckBoxState);
    function GetState(Index: Integer): TCheckBoxState;
    procedure ToggleClickCheck(Index: Integer);
    procedure InvalidateCheck(Index: Integer);
    function CreateWrapper(Index: Integer): TObject;
    function ExtractWrapper(Index: Integer): TObject;
    function GetWrapper(Index: Integer): TObject;
    function HaveWrapper(Index: Integer): Boolean;
    procedure WMDestroy(var Msg : TWMDestroy);message WM_DESTROY;
    function GetItemEnabled(Index: Integer): Boolean;
    procedure SetItemEnabled(Index: Integer; const Value: Boolean);
    procedure CNDrawItem(var Message: TWMDrawItem); message CN_DRAWITEM;
    procedure WMLButtonDown(var Message: TWMLButtonDown); message WM_LBUTTONDOWN;
  protected
    procedure DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState); override;
    function InternalGetItemData(Index: Integer): Longint; override;
    procedure InternalSetItemData(Index: Integer; AData: Longint); override;
    procedure SetItemData(Index: Integer; AData: LongInt); override;
    function GetItemData(Index: Integer): LongInt; override;
    procedure KeyPress(var Key: Char); override;
//    procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
    procedure ResetContent; override;
    procedure DeleteString(Index: Integer); override;
    procedure ClickCheck; dynamic;
    procedure CreateParams(var Params: TCreateParams); override;
    procedure CreateWnd; override;
    procedure DestroyWnd; override;
    function GetCheckWidth: Integer;
  public
    destructor Destroy; override;
    property Checked[Index: Integer]: Boolean read GetChecked write SetChecked;
    property ItemEnabled[Index: Integer]: Boolean read GetItemEnabled write SetItemEnabled;
    property State[Index: Integer]: TCheckBoxState read GetState write SetState;
  published
    property OnClickCheck: TNotifyEvent read FOnClickCheck write FOnClickCheck;
    property Align;
    property AllowGrayed: Boolean read FAllowGrayed write FAllowGrayed default False;
    property Anchors;
    property BiDiMode;
    property BorderStyle default bsNone;
    property Color;
    property Columns;
    property Constraints;
    property Ctl3D;
    property DragCursor;
    property DragKind;
    property DragMode;
    property Enabled;
    //property ExtendedSelect;
    property Font;
    property ImeMode;
    property ImeName;
    property IntegralHeight;
    property ItemHeight;
    property Items;
    //property MultiSelect;
    property ParentBiDiMode;
    property ParentColor;
    property ParentCtl3D;
    property ParentFont;
    property ParentShowHint;
    property PopupMenu;
    property ShowHint;
    property Sorted;
    property Style;
    property TabOrder;
    property TabStop;
    property TabWidth;
    property Visible;
    property OnClick;
    property OnContextPopup;
    property OnDblClick;
    property OnDragDrop;
    property OnDragOver;
    property OnDrawItem;
    property OnEndDock;
    property OnEndDrag;
    property OnEnter;
    property OnExit;
    property OnKeyDown;
    property OnKeyPress;
    property OnKeyUp;
    property OnMeasureItem;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property OnStartDock;
    property OnStartDrag;
  end;

implementation


uses Consts, sVclUtils, sMaskData, sUtils, sMessages, sConst, sGraphUtils, sAlphaGraph
{$IFDEF DELPHI6UP}
  , RTLConsts
{$ENDIF}
  ;

type
  TsCheckListBoxDataWrapper = class
  private
    FData: LongInt;
    FState: TCheckBoxState;
    FDisabled: Boolean;
    procedure SetChecked(Check: Boolean);
    function GetChecked: Boolean;
  public
    class function GetDefaultState: TCheckBoxState;
    property Checked: Boolean read GetChecked write SetChecked;
    property State: TCheckBoxState read FState write FState;
    property Disabled: Boolean read FDisabled write FDisabled;
  end;

var
  FCheckWidth, FCheckHeight: Integer;

procedure GetCheckSize;
begin
  with TBitmap.Create do
    try
      Handle := LoadBitmap(0, PChar(32759));
      FCheckWidth := Width div 4;
      FCheckHeight := Height div 3;
    finally
      Free;
    end;
end;

function MakeSaveState(State: TCheckBoxState; Disabled: Boolean): TObject;
begin
  Result := TObject((Byte(State) shl 16) or Byte(Disabled));
end;

function GetSaveState(AObject: TObject): TCheckBoxState;
begin
  Result := TCheckBoxState(Integer(AObject) shr 16);
end;

function GetSaveDisabled(AObject: TObject): Boolean;
begin
  Result := Boolean(Integer(AObject) and $FF);
end;

{ TsCheckListBoxDataWrapper }

function TsCheckListBoxDataWrapper.GetChecked: Boolean;
begin
  Result := FState = cbChecked;
end;

class function TsCheckListBoxDataWrapper.GetDefaultState: TCheckBoxState;
begin
  Result := cbUnchecked;
end;

procedure TsCheckListBoxDataWrapper.SetChecked(Check: Boolean);
begin
  if Check then FState := cbChecked else FState := cbUnchecked;
end;

{ TsCheckListBox }

procedure TsCheckListBox.ClickCheck;
begin
  if Assigned(FOnClickCheck) then FOnClickCheck(Self);
end;

procedure TsCheckListBox.CNDrawItem(var Message: TWMDrawItem);
begin
  if not CommonData.Skinned then
    with Message.DrawItemStruct^ do
      if not UseRightToLeftAlignment
        then rcItem.Left := rcItem.Left + GetCheckWidth
        else rcItem.Right := rcItem.Right - GetCheckWidth;
  inherited;
end;

procedure TsCheckListBox.CreateParams(var Params: TCreateParams);
begin
  inherited;
  with Params do if Style and (LBS_OWNERDRAWFIXED or LBS_OWNERDRAWVARIABLE) = 0 then Style := Style or LBS_OWNERDRAWFIXED;
end;

procedure TsCheckListBox.CreateWnd;
begin
  inherited CreateWnd;
  if FSaveStates <> nil then begin
    FSaveStates.Free;
    FSaveStates := nil;
  end;
  ResetItemHeight;
end;

function TsCheckListBox.CreateWrapper(Index: Integer): TObject;
begin
  Result := TsCheckListBoxDataWrapper.Create;
  inherited SetItemData(Index, LongInt(Result));
end;

procedure TsCheckListBox.DeleteString(Index: Integer);
begin
  if HaveWrapper(Index) then
    GetWrapper(Index).Free;
  inherited;
end;

destructor TsCheckListBox.Destroy;
begin
  FSaveStates.Free;
  inherited;
end;

procedure TsCheckListBox.DestroyWnd;
var
  I: Integer;
begin
  if Items.Count > 0 then
  begin
    FSaveStates := TList.Create;
    for I := 0 to Items.Count - 1 do
      FSaveStates.Add(MakeSaveState(State[I], not ItemEnabled[I]));
  end;
  inherited DestroyWnd;
end;

procedure TsCheckListBox.DrawCheck(R: TRect; AState: TCheckBoxState; AEnabled: Boolean; C : TCanvas);
var
  DrawState: Integer;
  DrawRect: TRect;
  OldBrushColor: TColor;
  OldBrushStyle: TBrushStyle;
  OldPenColor: TColor;
  Rgn, SaveRgn: HRgn;
begin
  DrawRect := R;
  if CommonData.Skinned then begin
    OffsetRect(DrawRect, - DrawRect.Left, - DrawRect.Top);
    BitBlt(C.Handle, DrawRect.Left, DrawRect.Top, FCheckWidth + 2, HeightOf(R), CommonData.FCacheBmp.Canvas.Handle, R.Left + 3, R.Top + 3, SRCCOPY);
  end;
  DrawRect.Left := DrawRect.Left + (DrawRect.Right - DrawRect.Left - FCheckWidth) div 2;
  DrawRect.Top := DrawRect.Top + (DrawRect.Bottom - DrawRect.Top - FCheckWidth) div 2;
  DrawRect.Right := DrawRect.Left + FCheckWidth;
  DrawRect.Bottom := DrawRect.Top + FCheckHeight;
  case AState of
    cbChecked: DrawState := DFCS_BUTTONCHECK or DFCS_CHECKED;
    cbUnchecked: DrawState := DFCS_BUTTONCHECK;
    else DrawState := DFCS_BUTTON3STATE or DFCS_CHECKED;
  end;
  if not AEnabled then DrawState := DrawState or DFCS_INACTIVE;

  if not CommonData.Skinned then begin
    SaveRgn := CreateRectRgn(0, 0, 0, 0);
    GetClipRgn(C.Handle, SaveRgn);
    with DrawRect do Rgn := CreateRectRgn(Left + 2, Top + 2, Right - 2, Bottom - 2);
    SelectClipRgn(C.Handle, Rgn);
    DeleteObject(Rgn);

    DrawFrameControl(C.Handle, DrawRect, DFC_BUTTON, DrawState);

    SelectClipRgn(C.Handle, SaveRgn);
    DeleteObject(SaveRgn);
    OldBrushStyle := C.Brush.Style;
    OldBrushColor := C.Brush.Color;
    OldPenColor := C.Pen.Color;
    C.Brush.Style := bsClear;
    C.Pen.Color := clBtnShadow;
    C.Rectangle(DrawRect.Left + 1, DrawRect.Top + 1, DrawRect.Right - 1, DrawRect.Bottom - 1);
    C.Brush.Style := OldBrushStyle;
    C.Brush.Color := OldBrushColor;
    C.Pen.Color := OldPenColor;
  end
  else DrawFrameControl(C.Handle, DrawRect, DFC_BUTTON, DrawState);
end;

procedure TsCheckListBox.DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState);
var
  SaveEvent: TDrawItemEvent;
  Enable: Boolean;
  ACheckWidth: Integer;
  TempBmp : Graphics.TBitmap;
  R : TRect;
  CI : TCacheInfo;
begin
  ACheckWidth := GetCheckWidth;
  if CommonData.Skinned then begin
    if CommonData.Skinned then if Self.ClientHeight = Height then begin
      Perform(CM_RECREATEWND, 0, 0); // Fixing of error in CalcSize..
      Perform(CM_INVALIDATE, 0, 0);