Intercepter couper/copier/coller dans un TEdit

unit MyEdit;

interface

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

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

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

FOnCut: TPreventNot if yEvent;
FOnCopy: TPreventNot if yEvent;
FOnPaste: TPreventNot if yEvent;
FOnClear: TPreventNot if yEvent;

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: TPreventNot if yEvent read FOnCut write FOnCut;
property OnCopy: TPreventNot if yEvent read FOnCopy write FOnCopy;
property OnPaste: TPreventNot if yEvent read FOnPaste write FOnPaste;
property OnClear: TPreventNot if yEvent 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.