Code:

unit ClipStrm;

   

interface uses Classes, Windows;

 

type

TClipboardStream = class(TStream)

private

   FMemory : pointer;

   FSize : longint;

   FPosition : longint;

   FFormat : word;

public

   constructor Create(fmt : word);

   destructor Destroy; override;

 

   function Read(var Buffer; Count : Longint) : Longint; override;

   function Write(const Buffer; Count : Longint) : Longint; override;

   function Seek(Offset : Longint; Origin : Word) : Longint; override;

end;

 

implementation uses SysUtils;

 

constructor TClipboardStream.Create(fmt : word);

 

var

tmp : pointer;

FHandle : THandle;

begin

FFormat := fmt;

OpenClipboard(0);

FHandle := GetClipboardData(FFormat);

FSize := GlobalSize(FHandle);

FMemory := AllocMem(FSize);

tmp := GlobalLock(FHandle);

MoveMemory(FMemory, tmp, FSize);

GlobalUnlock(FHandle);

FPosition := 0;

CloseClipboard;

end;

 

destructor TClipboardStream.Destroy;

begin

FreeMem(FMemory);

end;

 

function TClipboardStream.Read(var Buffer; Count : longint) : longint;

begin

if FPosition + Count > FSize then

Result := FSize - FPosition

else

Result := Count;

MoveMemory(@Buffer, PChar(FMemory) + FPosition, Result);

 

Inc(FPosition, Result);

end;

 

function TClipboardStream.Write(const Buffer; Count : longint) : longint;

var

FHandle : HGlobal;

tmp : pointer;

begin

ReallocMem(FMemory, FPosition + Count);

MoveMemory(PChar(FMemory) + FPosition, @Buffer, Count);

FPosition := FPosition + Count;

FSize := FPosition;

FHandle := GlobalAlloc(GMEM_MOVEABLE or GMEM_SHARE or GMEM_ZEROINIT, FSize);

try

tmp := GlobalLock(FHandle);

try

   MoveMemory(tmp, FMemory, FSize);

   OpenClipboard(0);

   SetClipboardData(FFormat, FHandle);

finally

   GlobalUnlock(FHandle);

 

end;

CloseClipboard;

except

GlobalFree(FHandle);

end;

Result := Count;

end;

 

function TClipboardStream.Seek(Offset : Longint; Origin : Word) : Longint;

begin

case Origin of

0 : FPosition := Offset;

1 : Inc(FPosition, Offset);

2 : FPosition := FSize + Offset;

end;

Result := FPosition;

end;

 

end.

  

Alexey Mahotkin Этот адрес электронной почты защищён от спам-ботов. У вас должен быть включен JavaScript для просмотра. (2:5020/433)

Взято из FAQ: Delphi and Windows API Tips'n'Tricks

Этот адрес электронной почты защищён от спам-ботов. У вас должен быть включен JavaScript для просмотра.

Добавить комментарий

Не использовать не нормативную лексику.

Просьба писать ваши замечания, наблюдения и все остальное,
что поможет улучшить предоставляемую информацию на этом сайте.

ВСЕ КОММЕНТАРИИ МОДЕРИРУЮТСЯ ВРУЧНУЮ, ТАК ЧТО СПАМИТЬ БЕСПОЛЕЗНО!


Защитный код
Обновить