listactns.pas

这是不可多得的源代码

{*******************************************************}
{                                                       }
{       Borland Delphi Visual Component Library         }
{                                                       }
{  Copyright (c) 1995,2001 Borland Software Corporation }
{                                                       }
{*******************************************************}

unit ListActns;

interface

uses Classes, Controls, ActnList, ImgList;

type

  TListControlItems = class;

  TListControlItem = class(TCollectionItem)
  private
    FListControlItems: TListControlItems;
  protected
    FCaption: String;
    FData: Pointer;
    FImageIndex: TImageIndex;
    procedure Changed;
    function GetDisplayName: String; override;
    procedure SetCaption(const Value: String); virtual;
    procedure SetData(const Value: Pointer); virtual;
    procedure SetImageIndex(const Value: TImageIndex); virtual;
  public
    constructor Create(Collection: TCollection); override;
    procedure Assign(Source: TPersistent); override;
    property Data: Pointer read FData write SetData;
  published
    property Caption: String read FCaption write SetCaption;
    property ImageIndex: TImageIndex read FImageIndex write SetImageIndex default -1;
  end;

  TListItemsSortType = (stNone, stData, stText, stBoth);
  TListCompareEvent = function(List: TListControlItems;
    Item1, Item2: TListControlItem): Integer of object;
  TListItemsCompare = function(List: TListControlItems;
    Index1, Index2: Integer): Integer;

  TListControlItems = class(TOwnedCollection)
  private
    FCaseSensitive: Boolean;
    FSortType: TListItemsSortType;
    FOnCompare: TListCompareEvent;
    procedure ExchangeItems(Index1, Index2: Integer);
    function GetListItem(const Index: Integer): TListControlItem;
    procedure QuickSort(L, R: Integer; SCompare: TListItemsCompare);
    procedure SetSortType(const Value: TListItemsSortType);
  protected
    function CompareItems(I1, I2: TListControlItem): Integer; virtual;
  public
    constructor Create(AOwner: TPersistent; ItemClass: TCollectionItemClass);  
    function Add: TListControlItem;
    procedure Sort;
    procedure CustomSort(Compare: TListItemsCompare);
    property Items[const Index: Integer]: TListControlItem read GetListItem; default;
  published
    property CaseSensitive: Boolean read FCaseSensitive write FCaseSensitive default False;
    property SortType: TListItemsSortType read FSortType write SetSortType default stNone;
    property OnCompare: TListCompareEvent read FOnCompare write FOnCompare;
  end;

{ TCustomListAction }

  TCustomListAction = class;
  TGetItemCountEvent = procedure(Sender: TCustomListAction;
    var Count: Integer) of object;
  TItemSelectedEvent = procedure(Sender: TCustomListAction;
    Control: TControl) of object;

  TCustomListAction = class(TCustomAction)
  private
    FActive: Boolean;
    FActivated: Boolean;
    FImages: TCustomImageList;
    FInUpdate: Boolean;
    FLoadedImages: TCustomImageList;
    FLoading: Boolean;
    FOnGetItemCount: TGetItemCountEvent;
    FOnItemSelected: TItemSelectedEvent;
    FItemIndex: Integer;
    procedure SetActive(const Value: Boolean);
    procedure SetImages(const Value: TCustomImageList);
    procedure SetItemIndex(const Value: Integer);
  protected
    function GetCount: Integer; virtual;
    function GetString(Index: Integer): String; virtual;
    procedure Loaded; override;
    procedure SetString(Index: Integer; const Value: String); virtual;
    property Images: TCustomImageList read FImages write SetImages;
    property Loading: Boolean read FLoading;
    property OnGetItemCount: TGetItemCountEvent read FOnGetItemCount
      write FOnGetItemCount;
    property OnItemSelected: TItemSelectedEvent read FOnItemSelected write FOnItemSelected;
  public
    constructor Create(AOwner: TComponent); override;
    procedure ExecuteTarget(Target: TObject); override;
    function HandlesTarget(Target: TObject): Boolean; override;
    property Active: Boolean read FActive write SetActive default True;
    property Count: Integer read GetCount;
    property ItemIndex: Integer read FItemIndex write SetItemIndex;
    property Strings[Index: Integer]: String read GetString write SetString; default;
  end;

{ TVirtualListAction }

  TGetVirtualItemEvent = procedure(Sender: TCustomListAction; const Index: Integer;
    var Value: String; var ImageIndex: Integer; var Data: Pointer) of object;

  TVirtualListAction = class(TCustomListAction)
  private
    FOnGetItem: TGetVirtualItemEvent;
  protected
    function GetItem(const Index: Integer; var Value: String;
      var ImageIndex: Integer; var Data: Pointer): Boolean;
    function GetString(Index: Integer): String; override;
  public
    property Count;
  published
    property Active;
    property Caption;
    property Enabled;
    property HelpContext;
    property Hint;
    property Images;
    property ItemIndex default -1;
    property ShortCut;
    property SecondaryShortCuts;
    property Visible;
    property OnGetItem: TGetVirtualItemEvent read FOnGetItem write FOnGetItem;
    property OnGetItemCount;
    property OnItemSelected;
    property OnHint;
  end;

{ TStaticListAction }

  TStaticListAction = class;
  TGetItemEvent = procedure(Sender: TCustomListAction; const Index: Integer;
    var Item: TListControlItem) of object;

  TStaticListItems = class(TListControlItems)
  private
    FStaticListAction: TStaticListAction;
  protected
    procedure Notify(Item: TCollectionItem;
      Action: TCollectionNotification); override;
    procedure Update(Item: TCollectionItem); override;
  end;

  TListControlItemClass = class of TListControlItem;

  TStaticListAction = class(TCustomListAction)
  private
    FListItems: TStaticListItems;
    FOnGetItem: TGetItemEvent;
    procedure SetListitems(const Value: TStaticListItems);
  protected
    function GetItemClass: TListControlItemClass; virtual;
    function GetCount: Integer; override;
    function GetItem(const Index: Integer; AnItem: TListControlItem): Boolean;
    function GetString(Index: Integer): String; override;
    procedure SetString(Index: Integer; const Value: String); override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    property Count;
  published
    property Active;
    property Caption;
    property Enabled;
    property HelpContext;
    property Hint;
    property Images;
    property ItemIndex default -1;
    property Items: TStaticListItems read FListItems write SetListitems;
    property ShortCut;
    property SecondaryShortCuts;
    property Visible;
    property OnGetItem: TGetItemEvent read FOnGetItem write FOnGetItem;
    property OnItemSelected;
    property OnHint;
    property OnUpdate;
  end;

{ TListActionLink }

  TListActionLink = class(TWinControlActionLink)
  protected
    function IsActiveLinked: Boolean; virtual;
    procedure SetActive(const Value: Boolean); virtual;
    function IsImagesLinked: Boolean; virtual;
    procedure SetAction(Value: TBasicAction); override;
    procedure SetImages(Value: TCustomImageList); virtual;
    procedure SetItemIndex(const Value: Integer); virtual;
    procedure AddItem(AnItem: TListControlItem); overload; virtual;
    procedure AddItem(ACaption: String; AImageIndex: Integer;
      DataPtr: Pointer); overload; virtual;
    procedure RefreshControl;
  end;

implementation

uses SysUtils, ComCtrls, Consts, RTLConsts;

{ TListControlItem }

procedure TListControlItem.Assign(Source: TPersistent);
begin
  if Source is TListControlItem then
  begin
    if Assigned(Collection) then Collection.BeginUpdate;
    try
      Caption := TListControlItem(Source).Caption;
      ImageIndex := TListControlItem(Source).ImageIndex;
      Data := TListControlItem(Source).Data;
    finally
      if Assigned(Collection) then Collection.EndUpdate;
    end;
  end;
end;

procedure TListControlItem.Changed;
begin
  if Assigned(FListControlItems) then
    FListControlItems.Update(Self);
end;

constructor TListControlItem.Create(Collection: TCollection);
begin
  inherited Create(Collection);
  FImageIndex := -1;
end;

function TListControlItem.GetDisplayName: String;
begin
  if Length(Caption) > 0 then
    Result := Caption
  else
    Result := inherited GetDisplayName;
end;

procedure TListControlItem.SetCaption(const Value: String);
begin
  FCaption := Value;
  Changed;
end;

procedure TListControlItem.SetData(const Value: Pointer);
begin
  FData := Value;
  Changed;
end;

procedure TListControlItem.SetImageIndex(const Value: TImageIndex);
begin
  FImageIndex := Value;
  Changed;
end;

{ TListControlItems }

function ListItemsCompare(List: TListControlItems; Index1, Index2: Integer): Integer;
begin
  Result := List.CompareItems(List.Items[Index1], List.Items[Index2]);
end;

function TListControlItems.Add: TListControlItem;
begin
  Result := TListControlItem(inherited Add);
  Result.FListControlItems := Self;
end;

procedure TListControlItems.CustomSort(Compare: TListItemsCompare);
begin
  if (SortType <> stNone) and (Count > 1) then
    QuickSort(0, Count - 1, Compare);
end;

function TListControlItems.CompareItems(I1, I2: TListControlItem): Integer;
begin
  if Assigned(OnCompare) then
    Result := OnCompare(Self, I1, I2)
  else
    if CaseSensitive then
      Result := AnsiCompareStr(I1.Caption, I2.Caption)
    else
      Result := AnsiCompareText(I1.Caption, I2.Caption);
end;

procedure TListControlItems.ExchangeItems(Index1, Index2: Integer);
var
  Item1, Item2: TListControlItem;
  I1, I2: Integer;
begin
  Item1 := Items[Index1];
  Item2 := Items[Index2];
  I1 := Items[Index1].Index;
  I2 := Items[Index2].Index;
  Item1.Index := I2;
  Item2.Index := I1;
end;

procedure TListControlItems.QuickSort(L, R: Integer; SCompare: TListItemsCompare);
var
  I, J, P: Integer;
begin
  repeat
    I := L;
    J := R;
    P := (L + R) shr 1;
    repeat
      while SCompare(Self, I, P) < 0 do Inc(I);
      while SCompare(Self, J, P) > 0 do Dec(J);
      if I <= J then
      begin
        ExchangeItems(I, J);
        if P = I then
          P := J
        else if P = J then
          P := I;
        Inc(I);
        Dec(J);
      end;
    until I > J;
    if L < J then QuickSort(L, J, SCompare);
    L := I;
  until I >= R;
end;

function TListControlItems.GetListItem(
  const Index: Integer): TListControlItem;
begin
  Result := TListControlItem(GetItem(Index));
end;

procedure TListControlItems.SetSortType(const Value: TListItemsSortType);
begin
  if FSortType <> Value then
  begin
    FSortType := Value;
    if Value <> stNone then
      CustomSort(ListItemsCompare);
  end;
end;

procedure TListControlItems.Sort;
begin
  CustomSort(ListItemsCompare);
end;

constructor TListControlItems.Create(AOwner: TPersistent;
  ItemClass: TCollectionItemClass);
begin
  inherited Create(AOwner, ItemClass);
  FCaseSensitive := False;