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

Code:

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.