imobjlist.pas

Delphi中一直都没有能快速显示彩色文字信息的Memo控件而TRichEdit慢得无法在需要高速的场合使用

{*********************************************************}
{       TMemo-Compatible Component v1.0                   }
{       Copyright (c) 2000 Sebastian Reichelt             }
{---------------------------------------------------------}
{ InfoMemo v1.0 Reprogram from TMemo-Compatible Component }
{ zhang jin-song www.ynu.edu.cn                           }
{*********************************************************}

unit imObjList;
{$WEAKPACKAGEUNIT}

interface

uses
	Classes;

type
	TimObjectNotifyEvent = procedure(Sender, Item: TObject) of object;

	TimOwnedPersistent = class(TPersistent)
	private
		FOwner: TPersistent;
	protected
		procedure SetOwner(const Value: TPersistent); virtual;
		function GetOwner: TPersistent; override;
	public
		constructor Create(AOwner: TPersistent); virtual;
		destructor Destroy; override;
		property Owner: TPersistent read FOwner write SetOwner;
	published
	end;

	TimObjectList = class(TList)
	private
		FOwner: TObject;
	protected
		function Get(Index: Integer): TObject;
		procedure Put(Index: Integer; Item: TObject);
	public
		constructor Create(AOwner: TObject);
		function Add(Item: TObject): Integer;
		procedure Insert(Index: Integer; Item: TObject);
		procedure Delete(Index: Integer); overload;
		procedure Delete(Item: TObject); overload;
		function IndexOf(Item: TObject): Integer;
		property Items[Index: Integer]: TObject read Get write Put; default;
		property Owner: TObject read FOwner;
	end;

	TimContainerItem = class;

	TimSubItemNotifyEvent = procedure(Sender: TObject; Item: TimContainerItem) of object;

	TimReferenceList = class(TimObjectList)
	private
		FOnAdd: TimSubItemNotifyEvent;
		FOnDelete: TimSubItemNotifyEvent;
		function Get(Index: Integer): TimContainerItem;
	protected
	public
		destructor Destroy; override;
		procedure Clear; override;
		procedure Add(Item: TimContainerItem);
		procedure Delete(Item: TimContainerItem);
		procedure PerformItemAction(Action: Integer; Obj: TObject = nil); virtual;
		function IndexOf(Item: TimContainerItem): Integer;
		property Items[Index: Integer]: TimContainerItem read Get; default;
		property OnAdd: TimSubItemNotifyEvent read FOnAdd write FOnAdd;
		property OnDelete: TimSubItemNotifyEvent read FOnDelete write FOnDelete;
	end;

 {$WARNINGS OFF}
	TimObjectContainer = class(TOwnedCollection)
	private
		function GetContainerOwner: TPersistent;
	protected
	public
		procedure PerformItemAction(Action: Integer; Obj: TObject = nil); virtual;
		property Owner : TPersistent read GetContainerOwner;
	end;
 {$WARNINGS ON}

	TimActionNotifyEvent = procedure(Sender: TObject; Action: Integer; Obj: TObject) of object;

	TimContainerItem = class(TCollectionItem)
	private
		FOnAction: TimActionNotifyEvent;
		function GetItemOwner: TimObjectContainer;
		procedure SetItemOwner(const Value: TimObjectContainer);
	protected
		procedure PerformAction(Action: Integer; Obj: TObject); virtual;
	public
		property Owner: TimObjectContainer read GetItemOwner write SetItemOwner;
		property OnAction: TimActionNotifyEvent read FOnAction write FOnAction;
	end;

	TimConnectionList = class;

	TimConItem = class(TCollectionItem)
	private
		FConList: TimConnectionList;
		procedure SetConList(const Value: TimConnectionList);
	public
		destructor Destroy; override;
	published
		property ConList: TimConnectionList read FConList write SetConList;
	end;

	TimConCollection = class(TOwnedCollection)
	private
	public
		function SearchForList(List: TimConnectionList): TimConItem;
	end;

	TimConnectionNotifyEvent = procedure(Sender: TObject; Item: TimConnectionList) of object;

	TimConnectionList = class(TimOwnedPersistent)
	private
		FCollection: TimConCollection;
		FOnConnect: TimConnectionNotifyEvent;
		FOnDisconnect: TimConnectionNotifyEvent;
		FOnAction: TimActionNotifyEvent;
		function GetCount: Integer;
		procedure SetCollection(const Value: TimConCollection);
	protected
		procedure Add(Item: TimConnectionList);
		procedure Delete(Item: TimConnectionList);
		procedure PerformAction(Action: Integer; Obj: TObject = nil); virtual;
	public
		class procedure ConnectLists(List1, List2: TimConnectionList);
		class procedure DisconnectLists(List1, List2: TimConnectionList);
		constructor Create(AOwner: TPersistent); override;
		destructor Destroy; override;
		procedure Clear;
		procedure PerformItemAction(Action: Integer; Obj: TObject); virtual;
		procedure ConnectTo(List: TimConnectionList);
		procedure DisconnectFrom(List: TimConnectionList);
		property Count: Integer read GetCount;
		property OnConnect: TimConnectionNotifyEvent read FOnConnect write FOnConnect;
		property OnDisconnect: TimConnectionNotifyEvent read FOnDisconnect write FOnDisconnect;
		property OnAction: TimActionNotifyEvent read FOnAction write FOnAction;
	published
		property Collection: TimConCollection read FCollection write SetCollection;
	end;

implementation

{ TimObjectList }

function TimObjectList.Add(Item: TObject): Integer;
begin
	Result := inherited Add(Pointer(Item));
end;

procedure TimObjectList.Delete(Index: Integer);
begin
	inherited Delete(Index);
end;

procedure TimObjectList.Delete(Item: TObject);
begin
	inherited Delete(IndexOf(Item));
end;

function TimObjectList.Get(Index: Integer): TObject;
begin
	Result := TObject(inherited Get(Index));
end;

function TimObjectList.IndexOf(Item: TObject): Integer;
begin
	Result := inherited IndexOf(Pointer(Item));
end;

procedure TimObjectList.Insert(Index: Integer; Item: TObject);
begin
	inherited Insert(Index,Pointer(Item));
end;

procedure TimObjectList.Put(Index: Integer; Item: TObject);
begin
	inherited Put(Index,Pointer(Item));
end;

constructor TimObjectList.Create(AOwner: TObject);
begin
	inherited Create;
	FOwner := AOwner;
end;

{ TimReferenceList }

procedure TimReferenceList.Add(Item: TimContainerItem);
begin
	if IndexOf (Item) < 0 then
 begin
		if Assigned(FOnAdd) then	FOnAdd(Self,Item);
		inherited Add(Item);
	end;
end;

procedure TimReferenceList.Clear;
var
	I: Integer;
begin
	for I := Count - 1 downto 0 do	Items[I].Free;
	inherited;
end;

procedure TimReferenceList.Delete(Item: TimContainerItem);
begin
	if Assigned(FOnDelete) then	FOnDelete(Self,Item);
	inherited Delete(Item);
end;

destructor TimReferenceList.Destroy;
begin
	Clear;
	inherited;
end;

function TimReferenceList.Get(Index: Integer): TimContainerItem;
begin
	Result := TimContainerItem(inherited Get(Index));
end;

function TimReferenceList.IndexOf(Item: TimContainerItem): Integer;
begin
	Result := inherited IndexOf(Item);
end;

procedure TimReferenceList.PerformItemAction(Action: Integer; Obj: TObject);
var
	I: Integer;
begin
	for I := Count - 1 downto 0 do	Items[I].PerformAction(Action,Obj);
end;

{ TimContainerItem }

function TimContainerItem.GetItemOwner: TimObjectContainer;
begin
	Result := TimObjectContainer(Collection);
end;

procedure TimContainerItem.PerformAction(Action: Integer; Obj: TObject);
begin
	if Assigned(FOnAction) then	FOnAction(Self, Action, Obj);
end;

procedure TimContainerItem.SetItemOwner(const Value: TimObjectContainer);
begin
	Collection := Value;
end;

{ TimConnectionList }

procedure TimConnectionList.Add(Item: TimConnectionList);
begin
	if not Assigned(FCollection.SearchForList(Item)) then
 begin
		with TimConItem(FCollection.Add) do	ConList := Item;
	end;
end;

procedure TimConnectionList.Clear;
var
	I: Integer;
begin
	for I := Count - 1 downto 0 do
		DisconnectFrom(TimConItem(FCollection.Items[I]).ConList);
	FCollection.Clear;
end;

class procedure TimConnectionList.ConnectLists(List1, List2: TimConnectionList);
begin
	List1.Add(List2);
	List2.Add(List1);
end;

procedure TimConnectionList.ConnectTo(List: TimConnectionList);
begin
	ConnectLists(Self,List);
end;

constructor TimConnectionList.Create(AOwner: TPersistent);
begin
	inherited;
	FCollection := TimConCollection.Create(Self,TimConItem);
end;

procedure TimConnectionList.Delete(Item: TimConnectionList);
var
	I: TimConItem;
begin
	I := FCollection.SearchForList(Item);
	if Assigned(I) then	I.Free;
end;

destructor TimConnectionList.Destroy;
begin
	Clear;
	FCollection.Free;
	inherited;
end;

procedure TimConnectionList.DisconnectFrom(List: TimConnectionList);
begin
	DisconnectLists(Self,List);
end;

class procedure TimConnectionList.DisconnectLists(List1, List2: TimConnectionList);
begin
	List1.Delete(List2);
	List2.Delete(List1);
end;

function TimConnectionList.GetCount: Integer;
begin
	Result := FCollection.Count;
end;

procedure TimConnectionList.PerformAction(Action: Integer; Obj: TObject);
begin
	if Assigned(FOnAction) then	FOnAction(Self, Action, Obj);
end;

procedure TimConnectionList.PerformItemAction(Action: Integer; Obj: TObject);
var
	I: Integer;
begin
	for I := Count - 1 downto 0 do
		TimConItem(FCollection.Items[I]).ConList.PerformAction(Action, Obj);
end;

procedure TimConnectionList.SetCollection(const Value: TimConCollection);
begin
	FCollection.Assign(Value);
end;

{ TimObjectContainer }

function TimObjectContainer.GetContainerOwner: TPersistent;
begin
	Result := GetOwner;
end;

procedure TimObjectContainer.PerformItemAction(Action: Integer; Obj: TObject);
var
	I: Integer;
begin
	for I := Count - 1 downto 0 do
		TimContainerItem(Items[I]).PerformAction(Action, Obj);
end;

{ TimOwnedPersistent }

constructor TimOwnedPersistent.Create(AOwner: TPersistent);
begin
	inherited Create;
	SetOwner(AOwner);
end;

destructor TimOwnedPersistent.Destroy;
begin
	SetOwner(nil);
	inherited;
end;

function TimOwnedPersistent.GetOwner: TPersistent;
begin
	Result := FOwner;
end;

procedure TimOwnedPersistent.SetOwner(const Value: TPersistent);
begin
	FOwner := Value;
end;

{ TimConItem }

destructor TimConItem.Destroy;
begin
	SetConList(nil);
	inherited;
end;

procedure TimConItem.SetConList(const Value: TimConnectionList);
begin
	if Assigned(FConList) and Assigned (FConList.FOnDisconnect) then
		FConList.FOnDisconnect(FConList,TimConnectionList(TimConCollection(Collection).GetOwner));
	FConList := Value;
	if Assigned(FConList) and Assigned (FConList.FOnConnect) then
		FConList.FOnConnect(FConList,TimConnectionList(TimConCollection(Collection).GetOwner));
end;

{ TimConCollection }

function TimConCollection.SearchForList(List: TimConnectionList): TimConItem;
var
I :   Integer;
Res : TimConItem;
begin
	Result := nil;
	for I := 0 to Count - 1 do
 begin
		Res := TimConItem(Items [I]);
		if Res.ConList = List then
  begin
			Result := Res;
			Break;
		end;
	end;
end;

end.