treeintf.pas

是 delphi6的函数库

unit TreeIntf;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ExtCtrls, ComCtrls, DesignIntf, DesignEditors, DesignMenus, TypInfo, Contnrs,
  IniFiles, Menus, ImgList;

type

{ TSprig }

{ sprig \Sprig\, n.
  [AS. sprec; akin to Icel. sprek a stick. Cf. Spray a branch.]
  1. A small shoot or twig of a tree or other plant; a spray; as, a sprig of
     laurel or of parsley.
  2. A youth; a lad; -- used humorously or in slight disparagement.
     A sprig whom I remember, with a whey-face and a satchel, not so many
     years ago. --Sir W. Scott.
  3. A brad, or nail without a head.
  4. (Naut.) A small eyebolt ragged or barbed at the point.
  5. A leaf in Delphi's object treeview
  Source: Webster's Revised Unabridged Dictionary, well sort of anyway }

  TSprig = class;
  TSprigClass = class of TSprig;
  TSprigAction = procedure(AItem: TSprig) of object;
  TSprigIndex = class;
  TRootSprig = class;
  TRootSprigClass = class of TRootSprig;
  TSprigTreeNode = class;
  ISprigDesigner = interface;

  ISprigCollection = interface
    ['{0B6ABAEE-E1A4-4DAC-8E20-C6B741A5082D}']
    function RootSprigAssigned: Boolean;
    function RootSprig: TRootSprig;
    function GetSprigDesigner: ISprigDesigner;
    procedure SetSprigDesigner(const ASprigDesigner: ISprigDesigner);
    property SprigDesigner: ISprigDesigner read GetSprigDesigner write SetSprigDesigner;
  end;

  ISprigDesigner = interface
    ['{6AC141E3-2FBE-425E-B299-AB29E7DF3FBB}']
    function GetTreeView: TCustomTreeView;
    procedure BeforeItemsModified;
    procedure AfterItemsModified;
    function GetRootSprig: TRootSprig;
    procedure SetRootSprig(ARootSprig: TRootSprig);
    property RootSprig: TRootSprig read GetRootSprig write SetRootSprig;
  end;

  TInformant = class(TObject)
  private
    FNotifyList: TList;
    FDisableNotify: Integer;
    FNotifyNeeded: Boolean;
    FDestroying: Boolean;
  protected
    procedure Changed(AObj: TInformant); virtual;
  public
    procedure BeforeDestruction; override;
    destructor Destroy; override;
    property Destroying: Boolean read FDestroying;

    procedure DisableNotify;
    procedure EnableNotify;
    procedure Notification;
    procedure Notify(AObj: TInformant);
    procedure Unnotify(AObj: TInformant);
  end;

  TSprigDeleteStyle = (dsNormal, dsIgnore, dsAbort, dsCustom);

  TSprig = class(TInformant)
  private
    FRoot: TRootSprig;
    FParent: TSprig;
    FList: TObjectList;
    FItem: TPersistent;
    FTreeNode: TTreeNode;
    FImageIndex: TImageIndex;
    FCaption: string;
    FExpanded, FInvalid, FCollectionsDone, FHidden, FHiddenTested: Boolean;
    procedure SetExpanded(const Value: Boolean);
  protected
    function GetItem(Index: Integer): TSprig;
    function UniqueName: string; virtual;
    function CaptionFor(const AName: string; const ALabel: string = '';
      const AClass: string = ''): string;
    procedure ReparentChildren;
    procedure SelectItems(const AItems: array of TPersistent; ARuntimeChange: Boolean = True); virtual;
    procedure RuntimeChange; virtual;
    procedure DesigntimeChange; virtual;
    function FindItem(AItem: TPersistent; Recurse: Boolean): TSprig; virtual;
    function FindItemByName(const AName: string; AClass: TClass; Recurse: Boolean): TSprig; virtual;
    function FindItemByPath(const APath: string; Recurse: Boolean = True): TSprig; virtual;
    function GetDesigner(out ADesigner: IDesigner): Boolean; virtual;
    function GetImageIndex: TImageIndex; virtual;
    procedure SetImageIndex(const Value: TImageIndex); virtual;
    function GetStateIndex: TImageIndex; virtual;
    procedure BeginUpdate; virtual;
    procedure EnsureUpdate; virtual;
    procedure EndUpdate; virtual;
    function GetAddType(Index: Integer): string; virtual;
  public
    constructor Create(AItem: TPersistent); overload; virtual;
    destructor Destroy; override;
    procedure Invalidate;

    function Transient: Boolean; virtual;
    function AnyProblems: Boolean; virtual;
    property Invalid: Boolean read FInvalid;

    property Item: TPersistent read FItem;
    function Hidden: Boolean; virtual;
    function Ghosted: Boolean; virtual;
    function FocusItem: TPersistent; virtual;
    function ItemClass: TClass; virtual;
    function Owner: TSprig; virtual;

    procedure VisualRefresh; virtual;
    function TreeNodeFor(ATreeView: TCustomTreeView): TTreeNode; virtual;
    property TreeNode: TTreeNode read FTreeNode;
    property Expanded: Boolean read FExpanded write SetExpanded;
    property ImageIndex: TImageIndex read GetImageIndex write SetImageIndex;
    property StateIndex: TImageIndex read GetStateIndex;
    procedure ClearTreeNode; overload;
    procedure ClearTreeNode(ARecurse: Boolean; AFreeNode: Boolean = True); overload;

    function Name: string; virtual;
    function Caption: string; virtual;
    function Hint: string; virtual;

    procedure PrepareMenu(const AItems: IMenuItems); virtual;
    function ShowRegisteredMenus: Boolean; virtual;

    function DragClass: TClass;
    function DragOver(AItem: TSprig): Boolean; virtual;
    function DragOverTo(AParent: TSprig): Boolean; virtual;
    function DragDrop(AItem: TSprig): Boolean; virtual;
    function DragDropTo(AParent: TSprig): Boolean; virtual;
    function PaletteOver(ASprigClass: TSprigClass; AClass: TClass): Boolean; virtual;
    class function PaletteOverTo(AParent: TSprig; AClass: TClass): Boolean; virtual;

    function Add(AItem: TSprig): TSprig;
    function Find(AItem: TPersistent; Recurse: Boolean = True): TSprig; overload;
    function Find(const AName: string; Recurse: Boolean = True): TSprig; overload;
    function Find(const AName: string; AClass: TClass; Recurse: Boolean = True): TSprig; overload;
    function FindPath(const APath: string; Recurse: Boolean = True): TSprig;
    function IndexOf(AItem: TSprig): Integer;
    procedure ForEach(ABefore: TSprigAction; AAfter: TSprigAction = nil);
    procedure ClearUnneededSprigs;

    function DeleteStyle: TSprigDeleteStyle; virtual;
    function CustomDelete: Boolean; virtual;

    function CanMove(AUp: Boolean): Boolean; virtual;
    function Move(AUp: Boolean): Boolean; virtual;
    function CanAdd: Boolean; virtual;
    function AddTypeCount: Integer; virtual;
    property AddTypes[Index: Integer]: string read GetAddType;
    procedure AddType(Index: Integer); virtual;

    procedure SortItems; virtual;
    function SortByIndex: Boolean; virtual;
    function IncludeIndexInCaption: Boolean; virtual;
    function ItemIndex: Integer; virtual;
    function CopyGlyph(ABitmap: TBitmap): Boolean; virtual;

    property Root: TRootSprig read FRoot;
    property Parent: TSprig read FParent;
    function Parents(ASprig: TSprig): Boolean;
    function Path: string;
    property Items[Index: Integer]: TSprig read GetItem; default;
    function Count: Integer;
    function Index: Integer;
    procedure Reparent; virtual;
    function Construct(AClass: TComponentClass): TComponent; virtual;

    function SeekParent(AItem: TPersistent; Recurse: Boolean = True): TSprig; overload;
    function SeekParent(const AName: string; Recurse: Boolean = True): TSprig; overload;
    function SeekParent(const AName: string; AClass: TClass; Recurse: Boolean = True): TSprig; overload;
    class function ParentProperty: string; virtual;
    procedure FigureParent; virtual;
    procedure FigureChildren; virtual;
  end;

  // a sprig that represents something that doesn't actually exist
  TAbstractSprig = class(TSprig)
  public
    function Ghosted: Boolean; override;
  end;

  // an abstract sprig that only exists if it has children
  TTransientSprig = class(TAbstractSprig)
  public
    function Transient: Boolean; override;
  end;

  // collection variants of the above
  TAbstractCollectionSprig = class(TAbstractSprig)
  public
    constructor Create(AItem: TPersistent); override;
  end;
  TTransientCollectionSprig = class(TTransientSprig)
  public
    constructor Create(AItem: TPersistent); override;
  end;

  // a sprig that points to a persistent
  TPersistentSprig = class(TSprig)
  end;

  // a sprig that points to a component
  TComponentSprig = class(TPersistentSprig)
  private
    FOwner: TSprig;
  public
    constructor Create(AItem: TPersistent); override;
    constructor Create(AItem: TPersistent; AOwner: TSprig); overload;
    function UniqueName: string; override;
    function Owner: TSprig; override;
    //function ShowRegisteredMenus: Boolean; override;
    // TSprig's implimentation of FigureParent is TComponent aware
  end;
  TComponentSprigClass = class of TComponentSprig;

  TRootSprig = class(TPersistentSprig)
  private
    FIndex: TSprigIndex;
    FNamedItems,
    FPathedItems: TList;
    FRepopulating,
    FParentChanges: Boolean;
    FSprigDesigner: ISprigDesigner;
    FDesigner: IDesigner;
    FRepopulateNeeded: Boolean;
    FNeedUpdate: Boolean;
    FUpdateLocks: Integer;
    procedure ValidateParent(AItem: TSprig);
    procedure PreRefreshTreeView(AItem: TSprig);
    procedure PostRefreshTreeView(AItem: TSprig);
    procedure DepopulateTreeView(AItem: TSprig);
    procedure RestoreExpandState(AItem: TSprig);
    procedure StoreExpandState(AItem: TSprig);
    procedure SetSprigDesigner(const ASprigDesigner: ISprigDesigner);
    procedure SelectionSurvey(out ADeleteStyle: TSprigDeleteStyle; out AAllVisible: Boolean);
  protected
    function FindItem(AItem: TPersistent; Recurse: Boolean = True): TSprig; override;
    function FindItemByName(const AName: string; AClass: TClass; Recurse: Boolean): TSprig; override;
    function FindItemByPath(const APath: string; Recurse: Boolean = True): TSprig; override;
    procedure AddItem(ASprig: TSprig);
    procedure RemoveItem(ASprig: TSprig);
    function GetDesigner(out ADesigner: IDesigner): Boolean; override;
    function GetAddType(Index: Integer): String; override;
    function SelectedSprig(var ASprig: TSprig): Boolean;
  public
    constructor Create(AItem: TPersistent); override;
    destructor Destroy; override;
    procedure FigureParent; override;

    property SprigDesigner: ISprigDesigner read FSprigDesigner write SetSprigDesigner;
    property Designer: IDesigner read FDesigner write FDesigner;

    property Repopulating: Boolean read FRepopulating;
    function Repopulate: Boolean;
    function TreeView: TCustomTreeView;
    procedure RefreshTreeView;
    procedure StoreTreeState;
    procedure BeginUpdate; override;
    procedure EnsureUpdate; override;
    procedure EndUpdate; override;

    procedure ItemDeleted(AItem: TPersistent);
    procedure ItemInserted;
    procedure ItemsModified(AForceRepopulate: Boolean = True);

    procedure RuntimeChange; override;
    procedure DesigntimeChange; override;
    procedure SelectItems(const AItems: array of TPersistent; ARuntimeChange: Boolean = True); override;

    // these are not used to operate on the root but its children
    function CanMove(AUp: Boolean): Boolean; override;
    function Move(AUp: Boolean): Boolean; override;
    function CanAdd: Boolean; override;
    procedure AddType(Index: Integer); override;
    function AddTypeCount: Integer; override;

    function EditAction(Action: TEditAction): Boolean;
    function GetEditState: TEditState;

    function DeleteStyle: TSprigDeleteStyle; override;

    function PaletteOver(ASprigClass: TSprigClass; AClass: TClass): Boolean; override;
    function AcceptsClass(AClass: TClass): Boolean; virtual;

    property RepopulateNeeded: Boolean read FRepopulateNeeded write FRepopulateNeeded;
  end;

  TSprigTreeNode = class(TTreeNode)
  public
    destructor Destroy; override;
  end;

  TSprigIndex = class(TObject)
  private
    FList: TObjectList;
  public
    constructor Create;
    destructor Destroy; override;

    procedure Add(ASprig: TSprig);
    procedure Remove(ASprig: TSprig);
    function Find(AItem: TPersistent): TSprig;
  end;

  TPropertySprig = class(TPersistentSprig)
  public
    function Ghosted: Boolean; override;
    function DeleteStyle: TSprigDeleteStyle; override;
  end;

  TCollectionSprig = class(TPropertySprig)
  private
    FPropName: string;
    FOwner: TSprig;
  protected
    function GetAddType(Index: Integer): string; override;
  public
    constructor Create(AItem: TPersistent); override;
    function Name: string; override;
    function Caption: string; override;
    procedure FigureParent; override;
    procedure FigureChildren; override;
    function Owner: TSprig; override;

    function SortByIndex: Boolean; override;
    procedure AddType(Index: Integer); override;
    function AddTypeCount: Integer; override;

    function DeleteStyle: TSprigDeleteStyle; override;
    function CustomDelete: Boolean; override;
  end;

  TCollectionItemSprig = class(TPersistentSprig)
  private
    FOwner: TSprig;
  protected
    function GetAddType(Index: Integer): string; override;
  public
    function Name: string; override;
    procedure FigureParent; override;
    function Owner: TSprig; override;
    function Ghosted: Boolean; override;
    function ItemIndex: Integer; override;
    function IncludeIndexInCaption: Boolean; override;
    function DragOverTo(AParent: TSprig): Boolean; override;
    function DragDropTo(AParent: TSprig): Boolean; override;
    procedure AddType(Index: Integer); override;
    function AddTypeCount: Integer; override;
  end;

  TSprigType = class(TObject)
  private
    FGroup: Integer;
    FClass: TClass;
    FSprigClass: TSprigClass;
  public
    constructor Create(const AClass: TClass; const ASprigClass: TSprigClass);
    function Score(const AClass: TClass): Integer;
    property SprigClass: TSprigClass read FSprigClass;
  end;

  TGUIDArray = array of TGUID;

  TSprigIntfType = class(TObject)
  private
    FGroup: Integer;
    FInterfaces: TGUIDArray;
    FSprigClass: TSprigClass;
  public
    constructor Create(const AInterfaces: TGUIDArray; const ASprigClass: TSprigClass);
    function Match(const AClass: TClass): Boolean;
    property SprigClass: TSprigClass read FSprigClass;
  end;

  TSprigTypeList = class(TObject)
  private
    FList: TObjectList;
    FLastClass: TClass;
    FLastSprigClass: TSprigClass;

    FInterfaceList: TObjectList;
  protected
    procedure ClearCache;
    function MatchCache(const AClass: TClass): TSprigClass;
    function MatchClass(const AClass: TClass): TSprigClass;
  public
    constructor Create;
    destructor Destroy; override;
    function Match(const AClass: TClass): TSprigClass;
    procedure Add(const AClass: TClass; const ASprigClass: TSprigClass); overload;
    procedure Add(const AInterfaces: TGUIDArray; const ASprigClass: TSprigClass); overload;
    procedure FreeEditorGroup(AGroup: Integer);
  end;

  TDragSprigs = class(TDragControlObjectEx)
  private
    FSprigs: TList;
    function GetSprig(Index: Integer): TSprig;
  public
    constructor Create(AControl: TControl); override;
    destructor Destroy; override;
    procedure Add(ASprig: TSprig);
    function Count: Integer;
    property Sprigs[Index: Integer]: TSprig read GetSprig;
  end;

procedure RegisterSprigType(const AClass: TClass; ASprigClass: TSprigClass); overload;
procedure RegisterSprigType(const AInterfaces: TGUIDArray; ASprigClass: TSprigClass); overload;

function FindBestSprigClass(AClass: TClass): TSprigClass; overload;
function FindBestSprigClass(AClass: TClass; AMinimumSprigClass: TSprigClass): TSprigClass; overload;

procedure RegisterRootSprigType(const AClass: TClass; ASprigClass: TRootSprigClass); overload;
procedure RegisterRootSprigType(const AInterfaces: TGUIDArray; ASprigClass: TRootSprigClass); overload;

function FindBestRootSprigClass(AClass: TClass): TRootSprigClass; overload;
function FindBestRootSprigClass(AClass: TClass; AMinimumSprigClass: TRootSprigClass): TRootSprigClass; overload;

var
  GShowClassNameInTreeView: Boolean = False;

const
  CFakeSprigImage = 0;
  CFakeCollectionSprigImage = 1;
  CPersistentSprigImage = 2;
  CCollectionSprigImage = 3;
  CComponentSprigImage = 4;
  CDataModuleSprigImage = 5;
  CControlSprigImage = 6;
  CUIControlSprigImage = 7;
  CUIContainerSprigImage = 8;
  CFormSprigImage = 9;
  CGhostedOffset = 10;

  CNoStateImage = 0;
  CCheckOutStateImage = 1;

  CCollectionName = '<Collection.%s>'; // DO NOT LOCALIZE

const
  CUIControlImageIndex: array [Boolean] of Integer = (CUIControlSprigImage,
                                                      CUIContainerSprigImage);

type
  TRootSprigList = class(TObject)
  private
    FList: TBucketList;
  public
    constructor Create;
    destructor Destroy; override;
    function FindRoot(const ADesigner: IDesigner; out ARootSprig: TRootSprig): Boolean;

    procedure DesignerClosed(const ADesigner: IDesigner; AGoingDormant: Boolean);
    procedure DesignerOpened(const ADesigner: IDesigner; AResurrecting: Boolean);
    procedure ItemDeleted(const ADesigner: IDesigner; AItem: TPersistent);
    procedure ItemInserted(const ADesigner: IDesigner; AItem: TPersistent);
    procedure ItemsModified(const ADesigner: IDesigner);
  end;

function RootSprigList: TRootSprigList;

type
  TCopySprigGlyphFunc = function(ASprig: TSprig; ABitmap: TBitmap): Boolean of object;

var
  CopySprigGlyphFunc: TCopySprigGlyphFunc;

implementation

uses
  DesignConst;

var
  InternalSprigTypeList: TSprigTypeList = nil;
  InternalRootSprigTypeList: TSprigTypeList = nil;

procedure RegisterSprigType(const AClass: TClass; ASprigClass: TSprigClass);
begin
  if InternalSprigTypeList = nil then
    InternalSprigTypeList := TSprigTypeList.Create;
  InternalSprigTypeList.Add(AClass, ASprigClass);
end;

procedure RegisterSprigType(const AInterfaces: TGUIDArray; ASprigClass: TSprigClass);
begin
  if InternalSprigTypeList = nil then
    InternalSprigTypeList := TSprigTypeList.Create;
  InternalSprigTypeList.Add(AInterfaces, ASprigClass);
end;


function FindBestSprigClass(AClass: TClass): TSprigClass;
begin
  Result := FindBestSprigClass(AClass, TSprig);
end;

function FindBestSprigClass(AClass: TClass;
  AMinimumSprigClass: TSprigClass): TSprigClass;
begin
  Result := nil;
  if InternalSprigTypeList <> nil then
  begin
    Result := InternalSprigTypeList.Match(AClass);