Delphi控件源码

开发平台：
Delphi

MMObjLst.pas：源码内容
							{========================================================================}
{=                (c) 1995-98 SwiftSoft Ronald Dittrich                 =}
{========================================================================}
{=                          All Rights Reserved                         =}
{========================================================================}
{=  D 01099 Dresden             = Tel.: +0351-8012255                   =}
{=  Loewenstr.7a                = info@swiftsoft.de                     =}
{========================================================================}
{=  Actual versions on http://www.swiftsoft.de/mmtools.html             =}
{========================================================================}
{=  This code is for reference purposes only and may not be copied or   =}
{=  distributed in any format electronic or otherwise except one copy   =}
{=  for backup purposes.                                                =}
{=                                                                      =}
{=  No Delphi Component Kit or Component individually or in a collection=}
{=  subclassed or otherwise from the code in this unit, or associated   =}
{=  .pas, .dfm, .dcu, .asm or .obj files may be sold or distributed     =}
{=  without express permission from SwiftSoft.                          =}
{=                                                                      =}
{=  For more licence informations please refer to the associated        =}
{=  HelpFile.                                                           =}
{========================================================================}
{=  $Date: 20.01.1998 - 18:00:00 $                                      =}
{========================================================================}
unit MMObjLst;
{$I COMPILER.INC}
{*********  Parts from  ****************************}
{                                                   }
{  Delphi Visual Component Library                  }
{                                                   }
{  Copyright (c) 1995 Borland International         }
{                                                   }
{***************************************************}
(* Send bug reports (with reproducable source)     *)
(*    LPL Soft : Robert Daignault                  *)
(*    Compuserve: 70302,1653                       *)
(*                                                 *)
(***************************************************)
interface
uses
{$IFDEF WIN32}
    Windows,
{$ELSE}
    WinTypes,
    WinProcs,
{$ENDIF}
    Classes,
    SysUtils,
    MMObj;
const
{ Remmove the following comment if you don't need 16/32 bit stream       }
{ compatability In that case, the default list size is 64K objects.      }
{ To change, simply edit the cMaxList constant for 32 bit only operation }
{$DEFINE Comp16_32Streams}
{$IFDEF WIN32}
 {$IFDEF Comp16_32Streams}
   cMaxList = MaxListSize;
 {$ELSE}
   cMaxList = $FFFE;   { 32 bit only operation : 64K objects }
 {$ENDIF}
{$ELSE}
   cMaxList = MaxListSize;
{$ENDIF}
   STREAMKENNUNG : Longint = $004A424F; { 'OBJ ' }
type
{$IFDEF WIN32}
 {$IFDEF Comp16_32Streams}
   TOLSize = SmallInt;
 {$ELSE}
   TOLSize = integer;   { 32 bit only operation : 64K objects }
 {$ENDIF}
{$ELSE}
   TOLSize = integer;
{$ENDIF}
 PObjects    = ^TObjects;
 TObjects    = array[0..cMaxList-1] of Pointer;
 {-- TObjectList --------------------------------------------------------}
 TObjectList = class(TMMObject)
 private
    FDestroy    : Boolean;
    FList       : PObjects;
    FCount      : TOLSize;
    FCapacity   : TOLSize;
 protected
    procedure Error; virtual;
    procedure Grow; virtual;
    procedure Put(Index: TOLSize; Item: TObject);virtual;
    function  Get(Index: TOLSize): TObject; virtual;
    procedure SetCapacity(NewCapacity: TOLSize);
    procedure SetCount(NewCount: TOLSize);
    Function  Allocate(Size: LongInt): Pointer;
    Procedure FreeItem(AnItem: Pointer); virtual;
    procedure ReadData(S: TStream); virtual;
    procedure WriteData(S: TStream); virtual;
    procedure DefineProperties(Filer: TFiler); override;
 public
    constructor Create; virtual;
    constructor CreateWithOptions(DestroyObjects: Boolean; InitialCapacity: TOLSize);
    destructor  Destroy; override;
    function    AddObject(Item: TObject): TOLSize; virtual;
    procedure   AddObjects(Objects: TObjectList); virtual;
    { Clear and Delete are identical. They do not Free each object }
    procedure   Clear; virtual;
    procedure   Delete(Index: TOLSize);
    procedure   DeleteAll;
    function    Remove(Item: TObject): TOLSize;
    { Free procedures first destroy tObjects and then call Delete procedures }
    procedure   FreeAll; virtual;
    procedure   FreeAt(Index: TOLSize);
    procedure   FreeObject(Item: TObject);
    function    First: TObject;
    function    Last: TObject;
    function    IndexOf(Item: TObject): TOLSize; virtual;
    procedure   Insert(Index: TOLSize; Item: TObject); virtual;
    procedure   Move(CurIndex, NewIndex: TOLSize);
    procedure   Exchange(Index1, Index2: TOLSize);
    procedure   Pack;
    constructor CreateFromFile(const FileName: string);
    procedure   SaveToFile(const FileName:String);
    procedure   LoadFromFile(const FileName: string);
    property OnChange;
    property OnChanging;
    property DestroyObjects: Boolean read FDestroy write FDestroy;
    property Capacity: TOLSize read FCapacity write SetCapacity;
    property Count: TOLSize read FCount;
    property Items[Index: TOLSize]: TObject read Get write Put; {$IFDEF WIN32}default;{$ENDIF}
  end;
  {-- TSortedObjectList -------------------------------------------------}
  TSortedObjectList = class(TObjectList)
  private
    FDuplicates: TDuplicates;
  protected
    function  KeyOf(Item: TObject): Pointer; virtual;
    procedure Put(Index: TOLSize; Item: TObject); override;
  public
    constructor CreateEx(WithDuplicates: TDuplicates);
    procedure ReadData(S: TStream); override;
    procedure WriteData(S: TStream); override;
    function  Compare(Key1, Key2: Pointer): integer; virtual; abstract;
    function  AddObject(Item: TObject): TOLSize; override;
    function  Search(Key: Pointer; var Index: TOLSize): Boolean;virtual;
    procedure Insert(Index: tOLSize; Item: TObject); override;
    function  IndexOf(Item: TObject): TOLSize; override;
    property  Items[Index: TOLSize]: TObject read Get;
    property  Duplicates: TDuplicates read FDuplicates;
  end;
  { Specialized memory Stream. Will Stream to a fixed memory buffer }
  { Mainly used when storing objects into a Object database record  }
  { NOTE: the memory is not freed. That is your job!                }
  { An exception will be raised if an operation causes the stream   }
  { position to go behond it's max size                             }
  TAbsMemStream = class(TStream)
  private
    FMemory: Pointer;
    FSize,
    FPosition: Longint;
  public
    Constructor Create(UseBuf: Pointer; MaxSize: LongInt);
    function Read(var Buffer; Count: Longint): Longint; override;
    function Write(const Buffer; Count: Longint): Longint; override;
    function Seek(Offset: Longint; Origin: Word): Longint; override;
    property Position: LongInt read FPosition;
    property Memory: Pointer read FMemory;
    property Size: Longint read FSize;
  end;
{ Streaming registration support }
Procedure  DoRegisterClass(const LoadProc,StoreProc:Pointer;Sender:tClass);
Function   IsRegistered(AClass:tClass):Boolean;
(******************************************************)
(* Misc. Usefull tools enabled by registering classes *)
(******************************************************)
Procedure  WriteObjectToStream(Source: TObject; S: TStream);
Function   ReadObjectFromStream(S: TStream): TObject;
(* CopyOf creates and returns a new instance of Source *)
Function   CopyOf(Source: TObject): TObject;
(*******************************************************)
(* Clipboard related functions. Cut & paste tObjects!  *)
(*******************************************************)
Function RegisterClipBoardType(const TypeName:String):Word;
  (* Use the result of RegisterClipBoardType as the ClipType
    Parameter to the 2 following procedures   *)
Function CopyObjectToClipboard(ClipType: Word; Source: TObject): Boolean;
Function PasteObjectFromClipboard(ClipType: Word): TObject;
{========================================================================}
implementation
{========================================================================}
Uses
    Consts
    {$IFDEF DELPHI6}
    ,RTLConsts
    {$ENDIF}
    ;
type
    TClassName = String[63];
    TRegisterRec = class(TObject)
      Obj: TClass; { Class type }
      { This is a pointer because otherwise a
         class instance would be required to register }
      DoLoad,
      DoStore : Pointer;
      Constructor Create(aClass: TClass; Loader, Storer: Pointer);
 end;
var
   ClassRegistry: TStringList;
{========================================================================}
constructor TRegisterRec.Create(aClass: TClass; Loader, Storer:Pointer);
begin
   inherited Create;
   Obj := aClass;
   DoLoad := Loader;
   DoStore := Storer;
end;
{========================================================================}
procedure DoRegisterClass(const LoadProc,StoreProc:Pointer;Sender:TClass);
begin
   ClassRegistry.AddObject(Sender.ClassName,
                 TRegisterRec.Create(Sender,LoadProc,StoreProc));
end;
{========================================================================}
function IsRegistered(aClass: TClass): Boolean;
Var
   Index: Integer;
begin
   Result := ClassRegistry.Find(aClass.ClassName,Index);
end;
{========================================================================}
function GetRegistration(aName: TClassName): TRegisterRec;
Var
   Index: Integer;
begin
   with ClassRegistry do
   if Find(aName,Index) then
      Result := TRegisterRec(Objects[Index])
   else
      Result := nil;
end;
{========================================================================}
function CreateInstanceByName(const Name: TClassName; var Loader: Pointer): TObject;
var
   R: TRegisterRec;
begin
   R := GetRegistration(Name);
   If R <> nil then
   begin
      Result := R.Obj.Create;
      Loader := R.DoLoad;
   end
   else raise EClassNotFound.CreateFmt('Class <%s> not registered',[Name]);
end;
{========================================================================}
procedure CallStreamProc(Obj: TObject; S: TStream; SProc: Pointer);
begin
   asm
      {$IFNDEF WIN32}
      les    di,S
      push   es
      push   di
      les    di,Obj
      push   es
      push   di
      call   DWord ptr SProc; { Call Obj's Load or Store proc }
      {$ELSE}
      {  In delphi32 : using registers calling
      EAX = pointer to Obj
      EDX = pointer to S
      ECX = SProc }
      call   ecx
      {$ENDIF}
   end;
end;
{========================================================================}
function CopyOf(Source: TObject): TObject;
Var
   S: TMemoryStream;
begin
   if Source <> nil then 
   begin
      S := TMemoryStream.Create;
      try
         WriteObjectToStream(Source,S);
         S.Seek(0,0);    { Rewind to beginning }
         Result := ReadObjectFromStream(S);
      finally
        S.Free;
      end;
   end
   else raise EClassNotFound.Create('Nil Source Class!');
end;
{========================================================================}
function ReadObjectFromStream(S: TStream): TObject;
var
   Name: TClassName;
   LoadProc: Pointer;
begin
   { Read the object name }
   S.ReadBuffer(Name[0],1);
   S.ReadBuffer(Name[1],Ord(Name[0]));
   { If Name is valid (registered)... }
   Result:=CreateInstanceByName(Name,LoadProc);
   { Then ask it to load itself }
   CallStreamProc(Result,S,LoadProc);
end;
{========================================================================}
procedure WriteObjectToStream(Source: TObject; S: TStream);
Var
   R: TRegisterRec;
   Name: TClassName;
begin
   If Source <> nil then
   begin
      Name := Source.ClassName;
      R := GetRegistration(Name);
      if R = nil then
         raise EClassNotFound.CreateFmt('Source Class <%s> not registered',[Name]);
      { First write out the object name }
      S.WriteBuffer(Name,Length(Name)+1);
      { And ask the object to write itself to S }
      CallStreamProc(Source,S,R.DoStore); { S now contains Source }
   end
   else raise EClassNotFound.Create('Nil Source Class!');
end;
{== TObjectList =========================================================}
constructor TObjectList.Create;
begin
   inherited Create;
   FCount := 0;
   FCapacity := 0;
   FDestroy := True;
end;
{-- TObjectList ---------------------------------------------------------}
constructor TObjectList.CreateWithOptions(DestroyObjects: Boolean;
                                          InitialCapacity: TOLSize);
begin
   Create;
   FDestroy := DestroyObjects;
   SetCapacity(InitialCapacity);
end;
{-- TObjectList ---------------------------------------------------------}
constructor TObjectList.CreateFromFile(const FileName: string);
begin
   Create;
   LoadFromFile(FileName);
end;
{-- TObjectList ---------------------------------------------------------}
destructor TObjectList.Destroy;
begin
   OnChange := nil;
   OnChanging := nil;
   FreeAll;
   Clear;
   inherited Destroy;
end;
{-- TObjectList ---------------------------------------------------------}
function TObjectList.AddObject(Item: TObject): TOLSize;
begin
   Result := FCount;
   Insert(Result, Item);
end;
{-- TObjectList ---------------------------------------------------------}
procedure TObjectList.AddObjects(Objects: TObjectList);
var
   i: integer;
begin
   BeginUpdate;
   try
      for i := 0 to Objects.Count-1 do
          AddObject(Objects.Items[i]);
   finally
      EndUpdate;
   end;
end;
{-- TObjectList ---------------------------------------------------------}
procedure TObjectList.Clear;
begin
   { Clear does not free it's objects. It's the same as calling DeleteAll }
   if FCount <> 0 then
   begin
      Changing;
      SetCount(0);
      SetCapacity(0);
      Changed;
   end;
end;
{-- TObjectList ---------------------------------------------------------}
Procedure TObjectList.FreeItem(AnItem: Pointer);
begin
   { Overwrite if Items are not objects }
   if FDestroy then TObject(AnItem).Free;
end;
{-- TObjectList ---------------------------------------------------------}
function TObjectList.Remove(Item: TObject): TOLSize;
begin
   Result := IndexOf(Item);
   if Result <> -1 then Delete(Result);
end;
{-- TObjectList ---------------------------------------------------------}
procedure TObjectList.Delete(Index: TOLSize);
begin
   if (Index < 0) or (Index >= FCount) then Error;
   Changing;
   dec(FCount);
   if Index < FCount then
      System.Move(FList^[Index+1], FList^[Index],
                 (FCount-Index)*SizeOf(TObject));
   Changed;
end;
{-- TObjectList ---------------------------------------------------------}
procedure TObjectList.DeleteAll;
begin
   Clear;
end;
{-- TObjectList ---------------------------------------------------------}
procedure TObjectList.FreeAt(Index: TOLSize);
begin
   if (Index < 0) or (Index >= FCount) then Error;
   FreeItem(FList^[Index]);
   Delete(Index);
end;
{-- TObjectList ---------------------------------------------------------}
procedure TObjectList.FreeAll;
var
   Index: TOLSize;
begin
   for Index := 0 to FCount-1 do
       FreeItem(FList^[Index]);
   Clear;
end;
{-- TObjectList ---------------------------------------------------------}
procedure TObjectList.FreeObject(Item: TObject);
begin
   try
      FreeAt(IndexOf(Item));
   except
      on EListError do
         raise EListError.CreateFmt('TObject %s not in item list',[Item.ClassName]);
   end;
end;
{-- TObjectList ---------------------------------------------------------}
procedure TObjectList.Error;
begin
   raise EListError.Create({$IFDEF DELPHI3}SListIndexError{$ELSE}LoadStr(SListIndexError){$ENDIF});
end;
{-- TObjectList ---------------------------------------------------------}
function TObjectList.First: TObject;
begin
   Result := Get(0);
end;
{-- TObjectList ---------------------------------------------------------}
function TObjectList.Last: TObject;
begin
   Result := Get(FCount - 1);
end;
{-- TObjectList ---------------------------------------------------------}
function TObjectList.Get(Index: TOLSize): TObject;
begin
   if (Index < 0) or (Index >= FCount) then Error;
   Result := FList^[Index];
end;
{-- TObjectList ---------------------------------------------------------}
procedure TObjectList.Grow;
Var
   Delta: TOLSize;
begin
   if FCapacity > 8 then Delta := 16
   else if FCapacity > 4 then Delta := 8
   else Delta := 4;
   SetCapacity(FCapacity+Delta);
end;
{-- TObjectList ---------------------------------------------------------}
function TObjectList.IndexOf(Item: TObject): TOLSize;
begin
   Result := 0;
   while (Result < FCount) and (FList^[Result] <> Item) do Inc(Result);
   if Result = FCount then Result := -1;
end;
{-- TObjectList ---------------------------------------------------------}
procedure TObjectList.Insert(Index: TOLSize; Item: TObject);
begin
   if (Index < 0) or (Index > FCount) then Error;
   Changing;
   if FCount = FCapacity then Grow;
   if Index < FCount then
   begin
      System.Move(FList^[Index], FList^[Index+1],
                  (FCount-Index)*SizeOf(TObject));
   end;
   FList^[Index] := Item;
   inc(FCount);
   Changed;
end;
{-- TObjectList ---------------------------------------------------------}
procedure TObjectList.Exchange(Index1, Index2: TOLSize);
var
  Item: TObject;
begin
   if (Index1 <> Index2) then
   begin
      if (Index1 < 0) or (Index1 >= FCount) or
         (Index2 < 0) or (Index2 >= FCount) then Error;
      Changing;
      Item := FList^[Index1];
      FList^[Index1] := FList^[Index2];
      FList^[Index2] := Item;
      Changed;
   end;
end;
{-- TObjectList ---------------------------------------------------------}
procedure TObjectList.Move(CurIndex, NewIndex: TOLSize);
var
   Item: TObject;
begin
   if CurIndex <> NewIndex then
   begin
      if (NewIndex < 0) or (NewIndex >= FCount) then Error;
      Item := Get(CurIndex);
      Delete(CurIndex);
      Insert(NewIndex, Item);
   end;
end;
{-- TObjectList ---------------------------------------------------------}
procedure TObjectList.Put(Index: TOLSize; Item: TObject);
begin
   if (Index < 0) or (Index >= FCount) then Error;
   FList^[Index] := Item;
end;
{-- TObjectList ---------------------------------------------------------}
procedure TObjectList.Pack;
var
   i: Integer;
begin
   for i := FCount-1 downto 0 do if Items[i] = nil then Delete(i);
end;
{-- TObjectList ---------------------------------------------------------}
procedure TObjectList.SetCapacity(NewCapacity: TOLSize);
var
   NewList: PObjects;
begin
   if (NewCapacity <> FCapacity) then
   begin
      if (NewCapacity < FCount) or (integer(NewCapacity)>=cMaxList) then Error;
      if NewCapacity = 0 then NewList := nil
      else
      begin
         NewList := Allocate(NewCapacity * SizeOf(tObject));
         if FCount <> 0 then System.Move(FList^, NewList^, FCount * SizeOf(tObject));
      end;
      if FCapacity <> 0 then FreeMem(FList, FCapacity * SizeOf(tObject));
      FList := NewList;
      FCapacity := NewCapacity;
   end;
end;
{-- TObjectList ---------------------------------------------------------}
procedure TObjectList.SetCount(NewCount: TOLSize);
begin
   if (NewCount < 0) or (integer(NewCount) >= cMaxList) then Error;
   if NewCount > FCapacity then SetCapacity(NewCount);
   if NewCount > FCount then
      FillChar(FList^[FCount], (NewCount - FCount) * SizeOf(TObject), 0);
   FCount := NewCount;
end;
{-- TObjectList ---------------------------------------------------------}
procedure TObjectList.DefineProperties(Filer: TFiler);
begin
   Filer.DefineBinaryProperty('ObjectContainer', ReadData, WriteData, FCount>0);
end;
{-- TObjectList ---------------------------------------------------------}
procedure TObjectList.ReadData(S: TStream);
Var
   ObjCount,
   Index: TOLSize;
   Kennung: Longint;
begin
   BeginUpdate;
   try
      S.ReadBuffer(Kennung,sizeOf(STREAMKENNUNG));
      if (Kennung <> STREAMKENNUNG) then
         raise EStreamError.Create('Invalid Object stream');
      FreeAll;
      { load stream items }
      S.ReadBuffer(FDestroy,SizeOf(FDestroy));
      S.ReadBuffer(ObjCount,SizeOf(Objcount));  { Read in Object count }
      if FCapacity-FCount < ObjCount then SetCapacity(FCount+ObjCount);
      { Read in Object Count }
      for Index := 0 to ObjCount-1 do
          AddObject(ReadObjectFromStream(S));
   finally
      EndUpdate;
   end;
end;
{-- TObjectList ---------------------------------------------------------}
procedure TObjectList.WriteData(S: TStream);
var
   Index,
   ObjCount: TOlSize;
begin
   { Write list to Stream }
   S.WriteBuffer(STREAMKENNUNG,SizeOf(STREAMKENNUNG));
   S.WriteBuffer(FDestroy,SizeOf(FDestroy));
   ObjCount := FCount;
   S.WriteBuffer(ObjCount,SizeOf(ObjCount));
   for Index := 0 to FCount-1 do
       WriteObjectToStream(Items[Index],S);
end;
{-- TObjectList ---------------------------------------------------------}
procedure TObjectList.SaveToFile(const FileName: String);
Var
   S: TFileStream;
begin
   { Will create Filename and overwrite any existing file
     of the same name                                     }
   S := TFileStream.Create(FileName,fmCreate);
   try
      WriteData(S);
   finally
      S.Free;
   end;
end;
{-- TObjectList ---------------------------------------------------------}
procedure TObjectList.LoadFromFile(const FileName: string);
Var
   S: TFileStream;
begin
   { LoadFromStream will add the Stream's content to it's current items }
   S := TFileStream.Create(FileName,fmOpenRead);
   try
      try
         ReadData(S)
      except
         raise EStreamError.Create('Unable to load Object stream');
      end;
   finally
      S.Free;
   end;
end;
{-- TObjectList ---------------------------------------------------------}
function TObjectList.Allocate(Size: LongInt): Pointer;
begin
   GetMem(Result,Size);
end;
{== TSortedList =========================================================}
constructor TSortedObjectList.CreateEx(WithDuplicates: TDuplicates);
begin
  inherited Create;
  FDuplicates:=WithDuplicates;
end;
{-- TSortedObjectList ---------------------------------------------------}
procedure TSortedObjectList.ReadData(S: TStream);
Var
   ObjCount,
   Index: TOLSize;
   Kennung: Longint;
begin
   BeginUpdate;
   try
      S.ReadBuffer(Kennung,sizeOf(STREAMKENNUNG));
      if (Kennung <> STREAMKENNUNG) then
         raise EStreamError.Create('Invalid Object stream');
      FreeAll;
      { load stream items }
      S.ReadBuffer(FDuplicates,sizeof(FDuplicates));
      S.ReadBuffer(FDestroy,SizeOf(FDestroy));
      S.ReadBuffer(ObjCount,SizeOf(Objcount));  { Read in Object count }
      if FCapacity-FCount < ObjCount then SetCapacity(FCount+ObjCount);
      { Read in Object Count }
      for Index := 0 to ObjCount-1 do
          AddObject(ReadObjectFromStream(S));
   finally
      EndUpdate;
   end;
end;
{-- TSortedObjectList ---------------------------------------------------}
procedure TSortedObjectList.WriteData(S: TStream);
var
   Index,
   ObjCount: TOlSize;
begin
   { Write list to Stream }
   S.WriteBuffer(STREAMKENNUNG,SizeOf(STREAMKENNUNG));
   S.WriteBuffer(FDuplicates,sizeof(FDuplicates));
   S.WriteBuffer(FDestroy,SizeOf(FDestroy));
   ObjCount := FCount;
   S.WriteBuffer(ObjCount,SizeOf(ObjCount));
   for Index := 0 to FCount-1 do
       WriteObjectToStream(Items[Index],S);
end;
{-- TSortedObjectList ---------------------------------------------------}
function TSortedObjectList.AddObject(Item: TObject): TOLSize;
begin
   Insert(-1, Item);
   Result := IndexOf(Item);
end;
{-- TSortedObjectList ---------------------------------------------------}
procedure TSortedObjectList.Insert(Index: TOLSize; Item: TObject);
begin
   { ignores the Index-Value! }
   if Search(KeyOf(Item),Index) then
   case FDuplicates of
      DupIgnore: Exit;
      DupError : raise EListError.Create('Duplicate Object index');
   end;
   inherited Insert(Index,Item);
end;
{-- TSortedObjectList ---------------------------------------------------}
function TSortedObjectList.KeyOf(Item: TObject): Pointer;
begin
   Result := Item;
end;
{-- TSortedObjectList ---------------------------------------------------}
function TSortedObjectList.IndexOf(Item: TObject): TOLSize;
begin
   if not Search(KeyOf(Item),Result) then Result := -1;
end;
{-- TSortedObjectList ---------------------------------------------------}
function TSortedObjectList.Search(Key: Pointer; var Index: TOLSize): Boolean;
var
  L, H, I, C: TOLSize;
begin
   Result := False;
   L := 0;
   H := Count - 1;
   while L <= H do
   begin
      I := (L + H) shr 1;
      C := Compare(KeyOf(Items[I]), Key);
      if C < 0 then L := I + 1
      else
      begin
         H := I - 1;
         if C = 0 then
         begin
            Result := True;
            if Duplicates <> dupAccept then L := I;
         end;
      end;
   end;
   Index := L;
end;
{-- TSortedObjectList ---------------------------------------------------}
procedure TSortedObjectList.Put(Index: TOLSize; Item: TObject);
begin
   raise EListError.Create('Cannot <Put> an Object in a sorted list!');
end;
{$IFNDEF WIN32}
procedure __AHSHIFT; far; external 'KERNEL' index 113;
function OffsetPointer(P: Pointer; Ofs: Longint): Pointer; assembler;
asm
        MOV     AX,Ofs.Word[0]
        MOV     DX,Ofs.Word[2]
        ADD     AX,P.Word[0]
        ADC     DX,0
        MOV     CX,OFFSET __AHSHIFT
        SHL     DX,CL
        ADD     DX,P.Word[2]
end;
{$ENDIF}
{== TAbsMemStream =======================================================}
constructor TAbsMemStream.Create(UseBuf: Pointer; MaxSize: LongInt);
begin
   inherited Create;
   FMemory := UseBuf;
   FSize := MaxSize;
   FPosition := 0;
end;
{-- TAbsMemStream -------------------------------------------------------}
function TAbsMemStream.Read(var Buffer; Count: Longint): Longint;
begin
   if (FPosition >= 0) and (Count >= 0) then
   begin
      Result := FSize - FPosition; { Remaining buffer }
      if Result >= Count then
         Result := Count
      else
         raise EStreamError.Create('MemStream reading behond limits');
      {$IFNDEF WIN32}
      hmemcpy(@Buffer, OffsetPointer(FMemory, FPosition), Result);
      {$ELSE}
      Move(Pointer(Longint(FMemory) + FPosition)^, Buffer, Result);
      {$ENDIF}
      inc(FPosition, Result);
   end
   else Result := 0;
end;
{-- TAbsMemStream -------------------------------------------------------}
function TAbsMemStream.Write(const Buffer; Count: Longint): Longint;
var
   Pos: Longint;
begin
   if (FPosition >= 0) and (Count >= 0) then
   begin
      Pos := FPosition + Count; { Ending FPosition }
      if (Pos>=FSize) then
         raise EStreamError.Create('MemStream writing behond limits');
      {$IFNDEF WIN32}
      hmemcpy(OffsetPointer(FMemory, FPosition), @Buffer, Count);
      {$ELSE}
      Move(Buffer, Pointer(Longint(FMemory) + FPosition)^, Count);
      {$ENDIF}
      FPosition := Pos;
      Result := Count;
   end
   else Result := 0;
end;
{-- TAbsMemStream -------------------------------------------------------}
function TAbsMemStream.Seek(Offset: Longint; Origin: Word): Longint;
begin
   case Origin of
      0: FPosition := Offset;
      1: Inc(FPosition, Offset);
      2: FPosition := FSize - Offset;
   end;
   if (FPosition>FSize) Or (FPosition<0) then
      raise EStreamError.Create('MemStream seeking behond limits');
   Result := FPosition;
end;
{========================================================================}
(* Clipboard related *)
Function RegisterClipBoardType(const TypeName: String): Word;
Var
   Name: PChar;
begin
   GetMem(Name,Length(TypeName)+1);
   StrpCopy(Name,TypeName);
   Result := RegisterClipBoardFormat(Name);
   FreeMem(Name,Length(TypeName)+1);
end;
{========================================================================}
function CopyObjectToClipboard(ClipType: word; Source:TObject): Boolean;
var
   S: TMemoryStream;
   MemHandle: THandle;
   MemPtr: Pointer;
begin
   if Source<>nil then
   begin
      Result:=False;
      S := TMemoryStream.Create;
      try
         WriteObjectToStream(Source,S);
         S.Seek(0,0);                         { Rewind to beginning }
         MemHandle := GlobalAlloc(GHND,S.Size); { allocate memory }
         if MemHandle = 0 then
            raise EOutOfMemory.Create('Not enough memory to copy object to clipboard');
            MemPtr:=GlobalLock(MemHandle);
         S.Read(MemPtr^,S.Size);{ read in the stream contents into MemPtr}
         GlobalUnlock(MemHandle);
         if SetClipboardData(ClipType, MemHandle) = 0 then
            GlobalFree(MemHandle)
         else
            Result := True;
            
      finally
         S.Free;
      end;
   end
   else raise EClassNotFound.Create('Nil Source Class!');
end;
{========================================================================}
function PasteObjectFromClipboard(ClipType: word): TObject;
var
   MemHandle:THandle;
   clipData:Pointer;
   ClipSize:longint;
   S: TAbsMemStream;
begin
   Result := nil;
   MemHandle := GetClipBoardData(ClipType);
   if MemHandle <> 0 then
   begin
      ClipSize := GlobalSize(MemHandle);
      ClipData := GlobalLock(MemHandle);
      S := TAbsMemStream.Create(ClipData,ClipSize);
      try
         Result := ReadObjectFromStream(S);
      finally
         GlobalUnlock(MemHandle);
         S.Free;
      end;
   end;
end;
{========================================================================}
Procedure TContainExitProc; far;
Var
   Idx:Integer;
begin
   for Idx := 0 to ClassRegistry.Count-1 do
       (ClassRegistry.Objects[Idx] as TRegisterRec).Free;
   ClassRegistry.Free;
end;
{========================================================================}
Initialization
   ClassRegistry := TStringList.Create;
   ClassRegistry.Sorted := True;
   ClassRegistry.Duplicates := dupIgnore;
   {$IFNDEF WIN32}
   AddExitProc(TContainExitProc);
   {$ENDIF}
{$IFDEF WIN32}
Finalization
  TContainExitProc;
{$ENDIF}
end.

						