Предотвратить работу с командами буфера обмена в TEdit

Оформил: DeeCo

unit MyEdit;

 interface

 uses
   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
   Dialogs, stdctrls, clipbrd;

 type
   TPreventNotifyEvent = procedure(Sender: TObject; Text: string; var Accept: Boolean) of object;

 type
   TMyEdit = class(TCustomEdit)
   private
     FPreventCut: Boolean;
     FPreventCopy: Boolean;
     FPreventPaste: Boolean;
     FPreventClear: Boolean;

     FOnCut: TPreventNotifyEvent;
     FOnCopy: TPreventNotifyEvent;
     FOnPaste: TPreventNotifyEvent;
     FOnClear: TPreventNotifyEvent;

     procedure WMCut(var Message: TMessage); message WM_CUT;
     procedure WMCopy(var Message: TMessage); message WM_COPY;
     procedure WMPaste(var Message: TMessage); message WM_PASTE;
     procedure WMClear(var Message: TMessage); message WM_CLEAR;
   protected
     { Protected declarations }
   public
     { Public declarations }
   published
     property PreventCut: Boolean read FPreventCut write FPreventCut default False;
     property PreventCopy: Boolean read FPreventCopy write FPreventCopy default False;
     property PreventPaste: Boolean read FPreventPaste write FPreventPaste default False;
     property PreventClear: Boolean read FPreventClear write FPreventClear default False;
     property OnCut: TPreventNotifyEvent read FOnCut write FOnCut;
     property OnCopy: TPreventNotifyEvent read FOnCopy write FOnCopy;
     property OnPaste: TPreventNotifyEvent read FOnPaste write FOnPaste;
     property OnClear: TPreventNotifyEvent read FOnClear write FOnClear;
   end;

 procedure Register;

 implementation

 procedure TMyEdit.WMCut(var Message: TMessage);
 var
   Accept: Boolean;
   Handle: THandle;
   HandlePtr: Pointer;
   CText: string;
 begin
   if FPreventCut then
     Exit;
   if SelLength = 0 then
     Exit;
   CText := Copy(Text, SelStart + 1, SelLength);
   try
     OpenClipBoard(Self.Handle);
     Accept := True;
     if Assigned(FOnCut) then
       FOnCut(Self, CText, Accept);
     if not Accept then
       Exit;
     Handle := GlobalAlloc(GMEM_MOVEABLE + GMEM_DDESHARE, Length(CText) + 1);
     if Handle = 0 then
       Exit;
     HandlePtr := GlobalLock(Handle);
     Move((PChar(CText))^, HandlePtr^, Length(CText));
     SetClipboardData(CF_TEXT, Handle);
     GlobalUnlock(Handle);
     CText := Text;
     Delete(CText, SelStart + 1, SelLength);
     Text := CText;
   finally
     CloseClipBoard;
   end;
 end;


 procedure TMyEdit.WMCopy(var Message: TMessage);
 var
   Accept: Boolean;
   Handle: THandle;
   HandlePtr: Pointer;
   CText: string;
 begin
   if FPreventCopy then
     Exit;
   if SelLength = 0 then
     Exit;
   CText := Copy(Text, SelStart + 1, SelLength);
   try
     OpenClipBoard(Self.Handle);
     Accept := True;
     if Assigned(FOnCopy) then
       FOnCopy(Self, CText, Accept);
     if not Accept then
       Exit;
     Handle := GlobalAlloc(GMEM_MOVEABLE + GMEM_DDESHARE, Length(CText) + 1);
     if Handle = 0 then
       Exit;
     HandlePtr := GlobalLock(Handle);
     Move((PChar(CText))^, HandlePtr^, Length(CText));
     SetClipboardData(CF_TEXT, Handle);
     GlobalUnlock(Handle);
   finally
     CloseClipBoard;
   end;
 end;


 procedure TMyEdit.WMPaste(var Message: TMessage);
 var
   Accept: Boolean;
   Handle: THandle;
   CText: string;
   LText: string;
   AText: string;
 begin
   if FPreventPaste then
     Exit;
   if IsClipboardFormatAvailable(CF_TEXT) then
   begin
     try
       OpenClipBoard(Self.Handle);
       Handle := GetClipboardData(CF_TEXT);
       if Handle = 0 then
         Exit;
       CText := StrPas(GlobalLock(Handle));
       GlobalUnlock(Handle);
       Accept := True;
       if Assigned(FOnPaste) then
         FOnPaste(Self, CText, Accept);
       if not Accept then
         Exit;
       LText := '';
       if SelStart > 0 then
         LText := Copy(Text, 1, SelStart);
       LText := LText + CText;
       AText := '';
       if (SelStart + 1) < Length(Text) then
         AText := Copy(Text, SelStart + SelLength + 1, Length(Text) - SelStart + SelLength + 1);
       Text := LText + AText;
     finally
       CloseClipBoard;
     end;
   end;
 end;


 procedure TMyEdit.WMClear(var Message: TMessage);
 var
   Accept: Boolean;
   CText: string;
 begin
   if FPreventClear then
     Exit;
   if SelStart = 0 then
     Exit;
   CText  := Copy(Text, SelStart + 1, SelLength);
   Accept := True;
   if Assigned(FOnClear) then
     FOnClear(Self, CText, Accept);
   if not Accept then
     Exit;
   CText := Text;
   Delete(CText, SelStart + 1, SelLength);
   Text := CText;
 end;


 procedure Register;
 begin
   RegisterComponents('Samples', [TMyEdit]);
 end;

 end.