mmobjlst.pas

一套及时通讯的原码

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.