自定义一个剪贴板类，实现对外无法粘贴的功能。

自定义一个剪贴板类，实现对外无法粘贴的功能。

{
example:
Copy:
  EmbeddedWB1.Copy;
  NDClipboard.CopyNDDataToClipboard;
Cut:
  EmbeddedWB1.Cut;
  NDClipboard.CopyNDDataToClipboard;
Paste:
  if NDClipboard.HasFormat(CF_NDCONTENT) then
  begin
    NDClipboard.CopyNDDataFromClipboard;//从剪贴板取出数据，并进行解壳操作
    EmbeddedWB1.Paste;//粘贴到目标中去
    NDClipboard.CopyNDDataToClipboard; //再将剪贴板里的数据重新加壳
  end
  else
    EmbeddedWB1.Paste;
}


unit  uNDClipboardClass ;

interface

uses
   Windows ,  Messages ,  SysUtils ,  Variants ,  Classes ,  Graphics ,  Controls ,  Forms ,
   Dialogs ,  StdCtrls ,  Clipbrd ;

const
   NDClipboardFormatStr  =  'CF_NDCONTENT' ;

type
   TNDClipboard  =  class ( TClipboard )
   public
     procedure  SetNdData ;
     procedure  GetNdData ;
     procedure  CopyNDDataToClipboard ;
     procedure  CopyNDDataFromClipboard ;

     procedure  SaveClipDataToStream ( var  AMem :  TMemoryStream );
     procedure  LoadClipDataFromStream ( var  AMem :  TMemoryStream );

   end ;

   TDataIdnet  =  array [ 0..2 ]  of  Char ;
   TClipboardFileHead  =  packed  record
     rIdent :  TDataIdnet ;
     rCount :  Word ;
   end ;

   TClipboardFileItem  =  packed  record
     rFormat :  Word ;
     rSize :  Longword ;
     rData :  Pointer ;
   end ;

const  rDataIdnet :  TDataIdnet  =  'cbf' ;



var
   CF_NDCONTENT :  Word ;

function  NDClipboard :  TNDClipboard ;
function  ClipboardSaveToStream ( mStream :  TStream ):  Boolean ;
function  ClipboardLoadFromStream ( mStream :  TStream ):  Boolean ;

procedure  CopyStreamToClipboard ( fmt :  Cardinal ;  S :  TStream );
procedure  CopyStreamFromClipboard ( fmt :  Cardinal ;  S :  TStream );
procedure  SaveClipboardFormat ( fmt :  Word ;  writer :  TWriter );
procedure  LoadClipboardFormat ( reader :  TReader );
procedure  SaveClipboard ( S :  TStream );
procedure  LoadClipboard ( S :  TStream );



implementation

function  ClipboardSaveToStream ( mStream :  TStream ):  Boolean ;
var
   vClipboardFileHead :  TClipboardFileHead ;
   vClipboardFileItem :  TClipboardFileItem ;
   I :  Integer ;
   vData :  THandle ;
begin
   Result  :=  False ;
   if  not  Assigned ( mStream )  then  Exit ;
   vClipboardFileHead . rIdent  :=  rDataIdnet ;
   vClipboardFileHead . rCount  :=  Clipboard . FormatCount ;
   mStream . Write ( vClipboardFileHead ,  SizeOf ( vClipboardFileHead ));
   try
     Clipboard . Open ;
     for  I  :=  0  to  Clipboard . FormatCount  -  1  do  begin
       vData  :=  GetClipboardData ( Clipboard . Formats [ I ]);
       vClipboardFileItem . rFormat  :=  Clipboard . Formats [ I ];
       vClipboardFileItem . rSize  :=  GlobalSize ( vData );
       vClipboardFileItem . rData  :=  GlobalLock ( vData );
       try
         mStream . Write ( vClipboardFileItem ,  SizeOf ( vClipboardFileItem )  -
           SizeOf ( vClipboardFileItem . rData ));
         mStream . Write ( vClipboardFileItem . rData ^,  vClipboardFileItem . rSize );
       finally
         GlobalUnlock ( vData );
       end ;
     end ;
   finally
     Clipboard . Close ;
   end ;
   Result  :=  True ;
end ;  { ClipboardSaveToStream }

procedure  CopyStreamToClipboard ( fmt :  Cardinal ;  S :  TStream );
var
   hMem :  THandle ;
   pMem :  Pointer ;
begin
   Assert ( Assigned ( S ));
   S . Position  :=  0 ;
   hMem  :=  GlobalAlloc ( GHND  or  GMEM_DDESHARE ,  S . Size );
   if  hMem  <>  0  then
   begin
     pMem  :=  GlobalLock ( hMem );
     if  pMem  <>  nil  then
     begin
       try
         S . Read ( pMem ^,  S . Size );
         S . Position  :=  0 ;
       finally
         GlobalUnlock ( hMem );
       end ;
       Clipboard . Open ;
       try
         Clipboard . SetAsHandle ( fmt ,  hMem );
       finally
         Clipboard . Close ;
       end ;
     end  { If }
     else
     begin
       GlobalFree ( hMem );
       OutOfMemoryError ;
     end ;
   end  { If }
   else
     OutOfMemoryError ;
end ;  { CopyStreamToClipboard }

procedure  CopyStreamFromClipboard ( fmt :  Cardinal ;  S :  TStream );
var
   hMem :  THandle ;
   pMem :  Pointer ;
begin
   Assert ( Assigned ( S ));
   hMem  :=  Clipboard . GetAsHandle ( fmt );
   if  hMem  <>  0  then
   begin
     pMem  :=  GlobalLock ( hMem );
     if  pMem  <>  nil  then
     begin
       try
         S . Write ( pMem ^,  GlobalSize ( hMem ));
         S . Position  :=  0 ;
       finally
         GlobalUnlock ( hMem );
       end ;
     end  { If }
     else
       raise  Exception . Create ( 'CopyStreamFromClipboard: could not lock global handle '  +
         'obtained from clipboard!' );
   end ;  { If }
end ;  { CopyStreamFromClipboard }

procedure  SaveClipboardFormat ( fmt :  Word ;  writer :  TWriter );
var
   fmtname :  array [ 0..128 ]  of  Char ;
   ms :  TMemoryStream ;
begin
   Assert ( Assigned ( writer ));
   if  0  =  GetClipboardFormatName ( fmt ,  fmtname ,  SizeOf ( fmtname ))  then
     fmtname [ 0 ]  :=  #0 ;
   ms  :=  TMemoryStream . Create ;
   try
     CopyStreamFromClipboard ( fmt ,  ms );
     if  ms . Size  >  0  then
     begin
       writer . WriteInteger ( fmt );
       writer . WriteString ( fmtname );
       writer . WriteInteger ( ms . Size );
       writer . Write ( ms . Memory ^,  ms . Size );
     end ;  { If }
   finally
     ms . Free
   end ;  { Finally }
end ;  { SaveClipboardFormat }

procedure  LoadClipboardFormat ( reader :  TReader );
var
   fmt :  Integer ;
   fmtname :  string ;
   Size :  Integer ;
   ms :  TMemoryStream ;
begin
   Assert ( Assigned ( reader ));
   fmt  :=  reader . ReadInteger ;
   fmtname  :=  reader . ReadString ;
   Size  :=  reader . ReadInteger ;
   ms  :=  TMemoryStream . Create ;
   try
     ms . Size  :=  Size ;
     reader . Read ( ms . memory ^,  Size );
     if  Length ( fmtname )  >  0  then
       fmt  :=  RegisterCLipboardFormat ( PChar ( fmtname ));
     if  fmt  <>  0  then
       CopyStreamToClipboard ( fmt ,  ms );
   finally
     ms . Free ;
   end ;  { Finally }
end ;  { LoadClipboardFormat }

procedure  SaveClipboard ( S :  TStream );
var
   writer :  TWriter ;
   i :  Integer ;
begin
   Assert ( Assigned ( S ));
   writer  :=  TWriter . Create ( S ,  4096 );
   try
     Clipboard . Open ;
     try
       writer . WriteListBegin ;
       for  i  :=  0  to  Clipboard . formatcount  -  1  do
         SaveClipboardFormat ( Clipboard . Formats [ i ],  writer );
       writer . WriteListEnd ;
     finally
       Clipboard . Close ;
     end ;  { Finally }
   finally
     writer . Free
   end ;  { Finally }
end ;  { SaveClipboard }

procedure  LoadClipboard ( S :  TStream );
var
   reader :  TReader ;
begin
   Assert ( Assigned ( S ));
   reader  :=  TReader . Create ( S ,  4096 );
   try
     Clipboard . Open ;
     try
       clipboard . Clear ;
       reader . ReadListBegin ;
       while  not  reader . EndOfList  do
         LoadClipboardFormat ( reader );
       reader . ReadListEnd ;
     finally
       Clipboard . Close ;
     end ;  { Finally }
   finally
     reader . Free
   end ;  { Finally }
end ;  { LoadClipboard }

function  ClipboardLoadFromStream ( mStream :  TStream ):  Boolean ;
var
   vClipboardFileHead :  TClipboardFileHead ;
   vClipboardFileItem :  TClipboardFileItem ;
   I :  Integer ;
   vData :  THandle ;
begin
   Result  :=  False ;
   if  not  Assigned ( mStream )  then  Exit ;
   if  mStream . Size  <=  SizeOf ( vClipboardFileHead )  then  Exit ;
   mStream . Read ( vClipboardFileHead ,  SizeOf ( vClipboardFileHead ));
   if  vClipboardFileHead . rIdent  <>  rDataIdnet  then  Exit ;
   Clipboard . Clear ;
   Clipboard . Open ;
   try
     for  I  :=  0  to  vClipboardFileHead . rCount  -  1  do  begin
       mStream . Read ( vClipboardFileItem ,  SizeOf ( vClipboardFileItem )  -
         SizeOf ( vClipboardFileItem . rData ));
       vData  :=  GlobalAlloc ( GMEM_MOVEABLE  +  GMEM_DDESHARE ,
         vClipboardFileItem . rSize );
       try
         vClipboardFileItem . rData  :=  GlobalLock ( vData );
         try
           mStream . Read ( vClipboardFileItem . rData ^,  vClipboardFileItem . rSize );
           SetClipboardData ( vClipboardFileItem . rFormat ,  vData );
         finally
           GlobalUnlock ( vData );
         end ;
       finally
         GlobalFree ( vData );
       end ;
     end ;
   finally
     Clipboard . Close ;
   end ;
   Result  :=  True ;
end ;  { ClipboardLoadFromStream }



procedure  TNDClipboard . SetNdData ;
var
   Data :  THandle ;
   DataPtr :  Pointer ;
   MemStream :  TMemoryStream ;
begin
   Open ;
   try
     Data  :=  NDclipboard . Handle ;
     if  Data  =  0  then  Exit ;
     DataPtr  :=  GlobalLock ( Data );
     if  DataPtr  =  nil  then  Exit ;
     try
       MemStream  :=  TMemoryStream . Create ;
       try
         MemStream . WriteBuffer ( DataPtr ^,  GlobalSize ( Data ));
         MemStream . Position  :=  0 ;
         SetBuffer ( CF_NDCONTENT ,  MemStream . Memory ^,  MemStream . Size );
       finally
         MemStream . Free ;
       end ;
     finally
       GlobalUnlock ( Data );
     end ;
   finally
     Close ;
   end ;
end ;

procedure  TNDClipboard . GetNdData ;
var
   Data :  THandle ;
   DataPtr :  Pointer ;
   MemStream :  TMemoryStream ;
begin
   Open ;
   try
     Data  :=  GetClipboardData ( CF_NDCONTENT );
     if  Data  =  0  then  Exit ;
     DataPtr  :=  GlobalLock ( Data );
     if  DataPtr  =  nil  then  Exit ;
     try
       MemStream  :=  TMemoryStream . Create ;
       try
         MemStream . WriteBuffer ( DataPtr ^,  GlobalSize ( Data ));
         MemStream . Position  :=  0 ;
       finally
         MemStream . Free ;
       end ;
     finally
       GlobalUnlock ( Data );
     end ;
   finally
     Close ;
   end ;
end ;

var
   FNDClipboard :  TNDClipboard ;

function  NDClipboard :  TNDClipboard ;
begin
   if  FNDClipboard  =  nil  then
     FNDClipboard  :=  TNDClipboard . Create ;
   Result  :=  FNDClipboard ;
end ;

procedure  TNDClipboard . CopyNDDataFromClipboard ;
var
   hbuf :  THandle ;
   bufptr :  Pointer ;
   mstream :  TMemoryStream ;
begin
   hbuf  :=  Clipboard . GetAsHandle ( CF_NDCONTENT );
   if  hbuf  <>  0  then  begin
     bufptr  :=  GlobalLock ( hbuf );
     if  bufptr  <>  nil  then  begin
       try
         mstream  :=  TMemoryStream . Create ;
         try
           mstream . WriteBuffer ( bufptr ^,  GlobalSize ( hbuf ));
           mstream . Position  :=  0 ;
           //-- 处理流的代码 --
           //ClipboardLoadFromStream(mstream)
           //LoadClipDataFromStream(mstream);
           LoadClipboard ( mstream );
         finally
           mstream . Free ;
         end ;
       finally
         GlobalUnlock ( hbuf );
       end ;
     end ;
   end ;

end ;

procedure  TNDClipboard . CopyNDDataToClipboard ;
var
   hbuf :  THandle ;
   bufptr :  Pointer ;
   mstream :  TMemoryStream ;
begin
   mstream  :=  TMemoryStream . Create ;
   try
     //-- 处理流的代码 --
     //ClipboardSaveToStream(mstream);
     //SaveClipDataToStream(mstream);
     SaveClipboard ( mstream );
     //mstream.SaveToFile('test');
     hbuf  :=  GlobalAlloc ( GMEM_MOVEABLE ,  mstream . size );
     try
       bufptr  :=  GlobalLock ( hbuf );
       try
         Move ( mstream . Memory ^,  bufptr ^,  mstream . size );
         Clipboard . SetAsHandle ( CF_NDCONTENT ,  hbuf );
       finally
         GlobalUnlock ( hbuf );
       end ;
     except
       GlobalFree ( hbuf );
       raise ;
     end ;
   finally
     mstream . Free ;
   end ;
end ;


procedure  TNDClipboard . LoadClipDataFromStream ( var  AMem :  TMemoryStream );
var
   MemStream ,  DataStream :  TMemoryStream ;
   i ,  FormatListLen ,  DataStreamLen :  Integer ;
   tmpStrings :  TStringList ;
begin
   DataStream  :=  TMemoryStream . Create ;
   tmpStrings  :=  TStringList . Create ;
   try
     clipbrd . Clipboard . Open ;
     Clipboard . Clear ;
     AMem . Position  :=  0 ;
     AMem . ReadBuffer ( FormatListLen ,  SizeOf ( Integer ));
     AMem . ReadBuffer ( DataStreamLen ,  SizeOf ( Integer ));
     DataStream . CopyFrom ( AMem ,  FormatListLen );
     DataStream . position  :=  0 ;
     tmpStrings . LoadFromStream ( DataStream );
     DataStream . Clear ;

     DataStream . CopyFrom ( AMem ,  DataStreamLen );
     DataStream . position  :=  0 ;

     if  DataStream . Size  <>  0  then  DataStream . Position  :=  0 ;

     for  i  :=  0  to  tmpStrings . Count  -  1  do
     begin
       FormatListLen  :=  StrToInt ( tmpStrings . Names [ i ]);
       DataStreamLen  :=  StrToInt ( tmpStrings . Values [ tmpStrings . Names [ i ]]);

       MemStream  :=  TMemoryStream . Create ;
       try
         MemStream . CopyFrom ( DataStream ,  DataStreamLen );
         MemStream . Position  :=  0 ;

         SetBuffer ( FormatListLen ,  MemStream . Memory ^,  DataStreamLen );
       finally
         MemStream . Free ;
       end ;
     end ;
   finally
     clipbrd . Clipboard . Close ;
     tmpStrings . Free ;
     DataStream . Free ;
   end ;

end ;

procedure  TNDClipboard . SaveClipDataToStream ( var  AMem :  TMemoryStream );
var
   Data :  THandle ;
   DataPtr :  Pointer ;
   MemStream ,  DataStream :  TMemoryStream ;
   i ,  tmpInt :  Integer ;
   tmpStrings :  TStringList ;
begin
   DataStream  :=  TMemoryStream . Create ;
   tmpStrings  :=  TStringList . Create ;
   try
     clipbrd . Clipboard . Open ;
     for  i  :=  0  to  Clipboard . FormatCount  -  1  do
     begin
       Data  :=  GetClipboardData ( Clipboard . Formats [ i ]);
       if  Data  =  0  then  Continue ;
       DataPtr  :=  GlobalLock ( Data );
       try
         if  DataPtr  =  nil  then  Continue ;
         MemStream  :=  TMemoryStream . Create ;
         try
           tmpInt  :=  GlobalSize ( Data );
           if  tmpInt  =  0  then
             beep ;
           MemStream . WriteBuffer ( DataPtr ^,  GlobalSize ( Data ));
           MemStream . Position  :=  0 ;
           tmpStrings . Add ( IntToStr ( Clipboard . Formats [ i ])  +  '='  +  IntToStr ( GlobalSize ( Data )));
           DataStream . WriteBuffer ( MemStream . Memory ^,  MemStream . Size );
         finally
           MemStream . Free ;
         end ;
       finally
         GlobalUnlock ( Data );
       end ;
     end ;
     if  tmpStrings . Count  <>  0  then
     begin
       AMem . Clear ;
       tmpInt  :=  Length ( tmpStrings . Text );
       AMem . WriteBuffer ( tmpInt ,  SizeOf ( Integer ));
       tmpInt  :=  DataStream . size ;
       AMem . WriteBuffer ( tmpInt ,  Sizeof ( Integer ));
       MemStream  :=  TMemoryStream . Create ;
       try
         tmpStrings . SaveToStream ( MemStream );
         AMem . WriteBuffer ( MemStream . Memory ^,  MemStream . Size );
       finally
         MemStream . Free ;
       end ;
       AMem . WriteBuffer ( DataStream . Memory ^,  DataStream . Size );
     end ;
   finally
     clipbrd . Clipboard . Close ;
     tmpStrings . Free ;
     DataStream . Free ;
   end ;
end ;

initialization
   CF_NDCONTENT  :=  RegisterClipboardFormat ( NDClipboardFormatStr );
   FNDClipboard  :=  nil ;
finalization
   FNDClipboard . Free ;

end .

posted on 2009-04-23 11:58  伊布 阅读( ...) 评论( ...) 编辑 收藏

转载于:https://www.cnblogs.com/b2020b/archive/2009/04/23/1441946.html