unitasedit.pas

仿速达界面控件

unit UnitASEdit;

interface

uses
  UnitASBase, Dialogs,
  Messages, Windows, SysUtils, Classes, Contnrs, Imm, Clipbrd,
  Controls, Forms, Menus, Graphics, UnitASUtils;

const
  Space             = WideChar(#20);

type
  TEditCharCase = (ecNormal, ecUpperCase, ecLowerCase);

  TActionType = (atDelete, atInsert);

  PEditAction = ^TEditAction;

  TEditAction = record
    ActionType: TActionType;

    PairedWithPriv: boolean;
    StartPosition: integer;
    DeletedFragment: WideString;
    Length: integer;
  end;

type

  TStack = class(TOrderedList)
  protected
    procedure PushItem(AItem: Pointer); override;
  end;

  TCustomASEdit = class;

  TEditActionStack = class(TStack)
  private
    FOwner: TCustomASEdit;
  public
    constructor Create(AOwner: TCustomASEdit);
    destructor Destroy; override;

    procedure FragmentInserted(StartPos, FragmentLength: integer;
      IsPairedWithPriv: boolean);
    procedure FragmentDeleted(StartPos: integer; Fragment: WideString);
    procedure CaretMovedBy(Shift: integer);

    function RollBackAction: boolean;
  end;

  TCustomASEdit = class(TASBase)
  private
    FBorderStyle: TBorderStyle;
    FText: WideString;
    FLMouseSelecting: boolean;
    FCaretPosition: Integer;
    FSelStart: integer;
    FSelLength: integer;
    FFirstVisibleChar: integer;
    FAutoSelect: boolean;
    FCharCase: TEditCharCase;
    FHideSelection: Boolean;
    FMaxLength: Integer;
    FReadOnly: Boolean;
    FOnChange: TNotifyEvent;
    FPasswordChar: Char;
    FTextAlignment: TAlignment;
    FActionStack: TEditActionStack;
    FModified: Boolean;
    FCustomCursor: Boolean;

    procedure WMGetDlgCode(var Msg: TWMGetDlgCode); message WM_GETDLGCODE;
    procedure WMCopy(var Message: TMessage); message WM_COPY;
    procedure WMPaste(var Message: TMessage); message WM_PASTE;
    procedure WMCut(var Message: TMessage); message WM_CUT;
    procedure WMUnDo(var Message: TMessage); message WM_UNDO;
    procedure WMLButtonDblClk(var Message: TWMLButtonDblClk); message
      WM_LBUTTONDBLCLK;
    { unicode }
    procedure WMImeStartComposition(var Message: TMessage); message
      WM_IME_STARTCOMPOSITION;
    procedure WMImeComposition(var Msg: TMessage); message WM_IME_COMPOSITION;
    procedure CMEnabledChanged(var Msg: TMessage); message CM_ENABLEDCHANGED;

    procedure CMCtl3DChanged(var Message: TMessage); message CM_CTL3DCHANGED;
    procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
    procedure CMTextChanged(var Msg: TMessage); message CM_TEXTCHANGED;
    procedure EMGETMODIFY(var Msg: TMessage); message EM_GETMODIFY;
    procedure EMSETMODIFY(var Msg: TMessage); message EM_SETMODIFY;
    procedure EMGETSEL(var Message: TMessage); message EM_GETSEL;
    procedure EMSETSEL(var Message: TMessage); message EM_SETSEL;

    function GetSelText: WideString;
    function GetVisibleSelText: WideString;
    function GetNextWordBeging(StartPosition: integer): integer;
    function GetPrivWordBeging(StartPosition: integer): integer;
    function GetSelStart: integer;
    function GetSelLength: integer;
    function GetText: WideString;
    procedure SetText(const Value: WideString);
    procedure SetFont(Value: TFont);

    procedure SetAutoSelect(const Value: boolean);
    procedure SetCharCase(const Value: TEditCharCase);
    procedure SetHideSelection(const Value: Boolean);
    procedure SetMaxLength(const Value: Integer);
    procedure SetPasswordChar(const Value: Char);
    procedure SetTextAlignment(const Value: TAlignment);
    function GetModified: Boolean;
    procedure SetModified(const Value: Boolean);
    procedure SetCursor(const Value: TCursor);
    procedure SetBorderStyle(const Value: TBorderStyle);
  protected

    function GetEditRect: TRect; virtual;
    function GetPasswordCharWidth: integer; virtual;
    function GetCharX(A: integer): integer; virtual;
    function GetCoordinatePosition(x: integer): integer; virtual;
    function GetSelRect: TRect; virtual;
    function GetAlignmentFlags: integer;

    procedure UpdateFirstVisibleChar; virtual;
    procedure UpdateCaretePosition; virtual;
    procedure UpdateCarete; virtual;
    procedure ShowCaret; virtual;
    procedure HideCaret; virtual;

    procedure Paint; override;
    procedure PaintBuffer; virtual;
    procedure PaintText; virtual;
    procedure PaintBackground(Rect: TRect; Canvas: TCanvas); virtual;

    procedure PaintSelectedText; virtual;
    procedure DrawPasswordChar(SymbolRect: TRect; Selected: boolean); virtual;

    function ValidText(NewText: WideString): boolean; virtual;
    function CanAutoSize(var NewWidth, NewHeight: Integer): Boolean; override;

    procedure BorderChanged; virtual;
    procedure HasFocus; virtual;
    procedure KillFocus; virtual;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState; x, y:
      integer); override;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState; x, y: integer);
      override;
    procedure MouseMove(Shift: TShiftState; x, y: integer); override;
    procedure KeyDown(var Key: Word; Shift: TShiftState); override;
    procedure KeyPress(var Key: Char); override;
    procedure SelectWord;
    procedure Change; dynamic;

    procedure DoUndo(Sender: TObject);
    procedure DoCut(Sender: TObject);
    procedure DoCopy(Sender: TObject);
    procedure DoPaste(Sender: TObject);
    procedure DoDelete(Sender: TObject);
    procedure DoSelectAll(Sender: TObject);

    procedure SetCaretPosition(const Value: integer); virtual;
    property CaretPosition: integer read FCaretPosition write SetCaretPosition;
    procedure CMEnter(var Message: TCMEnter); message CM_ENTER;
    procedure CMExit(var Message: TCMExit); message CM_EXIT;
    procedure WMSetFocus(var Message: TWMSetFocus); message WM_SETFOCUS;
    procedure SetSelStart(const Value: integer); virtual;
    procedure SetSelLength(const Value: integer); virtual;

    property CustomCursor: Boolean read FCustomCursor write FCustomCursor;
    procedure CreateParams(var Params: TCreateParams); override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Loaded; override;

    procedure CopyToClipboard;
    procedure PasteFromClipboard;
    procedure CutToClipboard;
    procedure ClearSelection;
    procedure SelectAll; virtual;
    procedure Clear; virtual;

    procedure UnDo; virtual;

    procedure InsertChar(Ch: WideChar);
    procedure InsertText(AText: WideString); virtual;
    procedure InsertAfter(Position: integer; S: WideString; Selected: boolean);
    procedure DeleteFrom(Position, Length: integer; MoveCaret: boolean);

    property BorderStyle: TBorderStyle read FBorderStyle write SetBorderStyle;
      //default bsSingle;
    property SelStart: integer read GetSelStart write SetSelStart;
    property SelLength: integer read GetSelLength write SetSelLength;
    property SelText: WideString read GetSelText;
    property Modified: Boolean read GetModified write SetModified;
  published
    property AutoSelect: boolean read FAutoSelect write SetAutoSelect default
      true;
    {
    property BevelKind;
    property BevelWidth;
    property BorderWidth;
    }
    //property BorderStyle;
    property CharCase: TEditCharCase read FCharCase write SetCharCase default
      ecNormal;
    property Cursor write SetCursor;

    property Font write SetFont;
    property HideSelection: Boolean read FHideSelection write SetHideSelection
      default True;
    property MaxLength: Integer read FMaxLength write SetMaxLength default 0;
    property PasswordChar: Char read FPasswordChar write SetPasswordChar
      default Char(#0);
    property ReadOnly: Boolean read FReadOnly write FReadOnly default False;
    property Text: WideString read GetText write SetText;
    property TextAlignment: TAlignment read FTextAlignment write SetTextAlignment
      default taLeftJustify;

    property OnChange: TNotifyEvent read FOnChange write FOnChange;

  end;

  TASEdit = class(TCustomASEdit)
  published
    property BorderStyle;
    property Anchors;
    property AutoSize;
    {
    property BevelKind;
    property BevelWidth;
    property BorderWidth;
    }

    property Constraints;
    property Color;
    property Ctl3D;
    property DragCursor;
    property DragKind;
    property DragMode;
    property Enabled;
    property ImeMode;
    property ImeName;
    property ParentFont;
    property ParentShowHint;
    property ParentColor;
    property ParentCtl3D;

    property ShowHint;
    property TabOrder;
    property TabStop default true;

    property Visible;

    property OnClick;
    property OnDblClick;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDock;
    property OnEndDrag;
    property OnEnter;
    property OnExit;
    property OnKeyDown;
    property OnKeyPress;
    property OnKeyUp;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property OnStartDock;
    property OnStartDrag;
    property WheelAccumulator;
  end;

implementation

const
  BorderStyles      : array[TBorderStyle] of DWORD = (0, WS_BORDER);

  { TStack }

procedure TStack.PushItem(AItem: Pointer);
begin
  List.Add(AItem);
end;

{ TEditActionStack}

constructor TEditActionStack.Create(AOwner: TCustomASEdit);
begin
  inherited Create;
  FOwner := AOwner;
end;

destructor TEditActionStack.Destroy;
var
  TmpItem           : PEditAction;
begin
  while AtLeast(1) do
  begin
    TmpItem := Pop;
    Finalize(TmpItem^);
    FreeMem(TmpItem);
  end;
  inherited;
end;

procedure TEditActionStack.FragmentDeleted(StartPos: integer;
  Fragment: WideString);
var
  TmpItem           : PEditAction;
begin
  if Fragment = '' then
    Exit;

  if (not AtLeast(1)) or
    not ((PEditAction(Peek)^.ActionType = atDelete) and
    (PEditAction(Peek)^.StartPosition - StartPos - Length(Fragment) <= 1) and
    (PEditAction(Peek)^.StartPosition - StartPos >= 0)) then
  begin

    New(TmpItem);
    Initialize(TmpItem^);
    Push(TmpItem);

    with TmpItem^ do
    begin
      ActionType := atDelete;
      StartPosition := StartPos;
      DeletedFragment := Fragment;
      PairedWithPriv := false;
    end;
  end
  else
    case PEditAction(Peek)^.ActionType of
      atDelete:
        begin
          if StartPos > 0 then
          begin
            if StartPos < PEditAction(Peek)^.StartPosition then
              PEditAction(Peek)^.DeletedFragment := Fragment +
                PEditAction(Peek)^.DeletedFragment
            else
              PEditAction(Peek)^.DeletedFragment :=
                PEditAction(Peek)^.DeletedFragment + Fragment;
            PEditAction(Peek)^.StartPosition := StartPos;
          end;
        end;
    end;
end;

procedure TEditActionStack.FragmentInserted(StartPos, FragmentLength: integer;
  IsPairedWithPriv: boolean);
var
  TmpItem           : PEditAction;
begin
  if FragmentLength = 0 then
    Exit;

  if (not AtLeast(1)) or
    not ((PEditAction(Peek)^.ActionType = atInsert) and
    (PEditAction(Peek)^.StartPosition + PEditAction(Peek)^.Length = StartPos))
    then
  begin
    New(TmpItem);
    Initialize(TmpItem^);
    Push(TmpItem);
    with TmpItem^ do
    begin
      ActionType := atInsert;
      StartPosition := StartPos;
      Length := FragmentLength;
      PairedWithPriv := IsPairedWithPriv;
    end;
  end
  else
    case PEditAction(Peek)^.ActionType of
      atInsert: PEditAction(Peek)^.Length := PEditAction(Peek)^.Length +
        FragmentLength;
    end;
end;

procedure TEditActionStack.CaretMovedBy(Shift: integer);
begin

end;

function TEditActionStack.RollBackAction: boolean;
var
  TmpItem           : PEditAction;
  WasPaired         : boolean;
begin
  Result := AtLeast(1);
  if not (Result and Assigned(FOwner)) then
    Exit;

  repeat
    TmpItem := Pop;
    with TmpItem^, FOwner do
      case ActionType of
        atDelete: InsertAfter(StartPosition - 1, DeletedFragment, true);
        atInsert: DeleteFrom(StartPosition, Length, true);
      end;
    WasPaired := TmpItem^.PairedWithPriv;
    Finalize(TmpItem^);
    Dispose(TmpItem);
  until not WasPaired;
end;

{ TCustomASEdit}

constructor TCustomASEdit.Create(AOwner: TComponent);
begin
  inherited;
  FActionStack := TEditActionStack.Create(Self);
  FBorderStyle := bsSingle;
  //ShowMessage('1');
  BevelWidth := 1;
  BorderWidth := 0;

  TabStop := true;
  Width := 121;
  Height := 21;
  Color := clWhite;

  FTextAlignment := taLeftJustify;
  FAutoSelect := true;
  AutoSize := true;
  FCharCase := ecNormal;
  FHideSelection := true;
  FMaxLength := 0;
  FReadOnly := false;
  FPasswordChar := Char(#0);
  FModified := True;
  //ShowMessage('2');
  FLMouseSelecting := false;

  FCaretPosition := 0;
  FSelStart := 0;
  FSelLength := 0;
  FFirstVisibleChar := 1;

  ControlStyle := ControlStyle + [csCaptureMouse];
  FCustomCursor := False;
  Cursor := Cursor;
  //ShowMessage('3');
end;

destructor TCustomASEdit.Destroy;
begin
  FActionStack.Free;
  inherited;
end;

procedure TCustomASEdit.Loaded;
begin
  inherited;
  AdjustSize;
end;

procedure TCustomASEdit.HasFocus;
begin
  UpdateCarete;
  CaretPosition := 0;
  if AutoSelect then
    SelectAll;
end;

procedure TCustomASEdit.KillFocus;
begin
  inherited;
  //HideCaret;
  DestroyCaret;
  Invalidate;
end;

function TCustomASEdit.GetCharX(a: integer): integer;
var
  WholeTextWidth    : integer;
  EditRectWidth     : integer;
begin
  Result := GetEditRect.Left;
  if FPasswordChar <> #0 then
    WholeTextWidth := Length(Text) * GetPasswordCharWidth
  else
    WholeTextWidth := TextWidth(Canvas, Copy(Text, 1, Length(Text)),
      DT_NOPREFIX);

  if a > 0 then
  begin
    Canvas.Font.Assign(Self.Font);
    if FPasswordChar <> #0 then
    begin
      if a <= Length(Text) then
        Result := Result + (a - FFirstVisibleChar + 1) * GetPasswordCharWidth
      else
        Result := Result + (Length(Text) - FFirstVisibleChar + 1) *
          GetPasswordCharWidth;
    end
    else
    begin
      if a <= Length(Text) then
        Result := Result + TextWidth(Canvas, Copy(Text, FFirstVisibleChar, a -
          FFirstVisibleChar + 1), DT_NOPREFIX)
      else
        Result := Result + TextWidth(Canvas, Copy(Text, FFirstVisibleChar,
          Length(Text) - FFirstVisibleChar + 1), DT_NOPREFIX);
    end;
  end;

  EditRectWidth := GetEditRect.Right - GetEditRect.Left;
  if WholeTextWidth < EditRectWidth then
    case TextAlignment of
      taRightJustify: Result := Result + (EditRectWidth - WholeTextWidth);
      taCenter: Result := Result + ((EditRectWidth - WholeTextWidth) div 2);
    end;
end;

function TCustomASEdit.GetCoordinatePosition(x: integer): integer;
var
  CurX              : double;
  TmpX,
    WholeTextWidth,
    EditRectWidth   : integer;
begin
  Result := FFirstVisibleChar - 1;
  if Length(Text) = 0 then
    Exit;

  if FPasswordChar <> #0 then
    WholeTextWidth := Length(Text) * GetPasswordCharWidth
  else
    WholeTextWidth := TextWidth(Canvas, Copy(Text, 1, Length(Text)),
      DT_NOPREFIX);

  EditRectWidth := GetEditRect.Right - GetEditRect.Left;
  TmpX := x;
  if WholeTextWidth < EditRectWidth then
    case TextAlignment of
      taRightJustify: TmpX := x - (EditRectWidth - WholeTextWidth);
      taCenter: TmpX := x - ((EditRectWidth - WholeTextWidth) div 2);
    end;

  if FPasswordChar <> #0 then
  begin
    Result := Result + (TmpX - GetEditRect.Left) div GetPasswordCharWidth;
    if Result < 0 then
      Result := 0
    else
      if Result > Length(Text) then
        Result := Length(Text);