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

=== Предотвратить работу с командами буфера обмена в TEdit ===
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.
Source: Взято с сайта: http://www.swissdelphicenter.ch
ID: 01884