Tips (1541)

Tip Bewertung (17):

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.