mwcustomedit.pas

完全不使用 Windows 标准 Edit Control 而实作出的改良版 TEdit 构件

{+--------------------------------------------------------------------------+
 | Class:       TmCustomEdit
 | Created:     11.98
 | Author:      Martin Waldenburg
 | Description: study on how to create a custom edit control without using
 |              a Windows edit control.
 | Version:     0.02 Beta
 | Copyright (c) 1998 Martin Waldenburg
 | All rights reserved.
 |
 | LICENCE CONDITIONS
 |
 | USE OF THE ENCLOSED SOFTWARE
 | INDICATES YOUR ASSENT TO THE
 | FOLLOWING LICENCE CONDITIONS.
 |
 |
 |
 | These Licence Conditions are exlusively
 | governed by the Law and Rules of the
 | Federal Republic of Germany.
 |
 | Redistribution and use in source and binary form, with or without
 | modification, are permitted provided that the following conditions
 | are met:
 |
 | 1. Redistributions of source code must retain the above copyright
 |    notice, this list of conditions and the following disclaimer.
 |    If the source is modified, the complete original and unmodified
 |    source code has to distributed with the modified version.
 |
 | 2. Redistributions in binary form must reproduce the above
 |    copyright notice, these licence conditions and the disclaimer
 |    found at the end of this licence agreement in the documentation
 |    and/or other materials provided with the distribution.
 |
 | 3. Software using this code must contain a visible line of credit.
 |
 | 4. If my code is used in a "for profit" product, you have to donate
 |    to a registered charity in an amount that you feel is fair.
 |    You may use it in as many of your products as you like.
 |    Proof of this donation must be provided to the author of
 |    this software.
 |
 | 5. If you for some reasons don't want to give public credit to the
 |    author, you have to donate three times the price of your software
 |    product, or any other product including this component in any way,
 |    but no more than $500 US and not less than $200 US, or the
 |    equivalent thereof in other currency, to a registered charity.
 |    You have to do this for every of your products, which uses this
 |    code separately.
 |    Proof of this donations must be provided to the author of
 |    this software.
 |
 |
 | DISCLAIMER:
 |
 | THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS'.
 |
 | ALL EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
 | THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
 | PARTICULAR PURPOSE ARE DISCLAIMED.
 |
 | IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT,
 | INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
 | (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
 | OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
 | INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
 | WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
 | NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
 | THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 |
 |  [e-mail]
+--------------------------------------------------------------------------+}


unit mwCustomEdit;

interface

uses
  Windows, mwOTA, Messages, SysUtils, Classes, Controls, Graphics, ExtCtrls, Forms;

type
  TmCustomEdit = class(TCustomControl)
  private
    FSelStart: Integer;
    FSelLength: Integer;
    FOnChange: TNotifyEvent;
    FMousePos: Integer;
    fTopLine: Integer;
    fLines: TStrings;
    fLeftChar: Integer;
    TextBM: TBitMap;
    ToCopy: TRect;
    fGutterWidth: Integer;
    fCaretX: Integer;
    fCaretY: Integer;
    fCaretYPix: Integer;
    fCaretVisible: Boolean;
    function GetBlancOffset: Integer;
    function HitTest(X, Y: Integer): Integer;
    function CaretXPix: Integer;
    function CaretYPix: Integer;
    procedure UpdateCaret;
    procedure SetText(Value: String);
    procedure SetSelStart(Value: Integer);
    procedure SetSelLength(Value: Integer);
    procedure SetSelText(Value: String);
    function GetSelText: String;
    function GetEditRect: TRect; virtual;
    function GetLineCount: Integer;
    function GetLinesInWindow: Integer;
    function GetLineText: String;
    function GetTextHeight: Integer;
    function GetCharWidth: Integer;
    procedure SetCaretX(Value: Integer);
    procedure SetCaretY(Value: Integer);
    procedure SetFont(const Value: TFont);
    procedure SetLineText(const Value: String);
    procedure SetTopLine(Value: Integer);
    function GetTopLine: Integer;
    function GetLeftChar: Integer;
    procedure SetLeftChar(Value: Integer);
    function GetCharsInWindow: Integer;
    procedure PaintControl;
    function GetOffset: Integer;
    function GetCaretX: Integer;
    function GetCaretY: Integer;
    procedure ComputeCaret(X, Y: Integer);
    procedure SetCaretPosition(X, Y: Integer);
  protected
    procedure PaintGutter; virtual;
    procedure PaintText; virtual;
    procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override;
    procedure UpdatePaint; virtual;
    function GetText: String; virtual;
    procedure Paint; override;
    procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
    procedure WMSetFocus(var Message: TWMSetFocus); message WM_SETFOCUS;
    procedure WMKillFocus(var Message: TWMSetFocus); message WM_KILLFOCUS;
    procedure WMWindowPosChanged(var Message: TWMWindowPosChanged); message WM_WINDOWPOSCHANGED;
    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 KeyPress(var Key: Char); override;
    procedure KeyDown(var Key: Word; Shift: TShiftState); override;
    procedure WMGetDlgCode(var Msg: TWMGetDlgCode); message WM_GETDLGCODE;
    procedure WMSize(var Message: TWMSize); message WM_SIZE;
    procedure WMMove(var Message: TWMMove); message WM_MOVE;
    procedure WMEraseBkgnd(var Msg: TMessage); message WM_ERASEBKGND;
    procedure WMPaste(var Msg: TMessage); message WM_PASTE;
    procedure WMCopy(var Msg: TMessage); message WM_COPY;
    procedure WMCut(var Msg: TMessage); message WM_CUT;
    procedure WMClear(var Msg: TMessage); message WM_CLEAR;
    procedure WMUndo(var Msg: TMessage); message WM_UNDO;
    procedure EMUndo(var Msg: TMessage); message EM_UNDO;
    procedure EMCanUndo(var Msg: TMessage); message EM_CANUNDO;
    procedure Change; virtual;
    procedure CreateParams(var Params: TCreateParams); override;
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
    Procedure CreateWnd; override;
    property BlancOffset: Integer read GetBlancOffset;
    property Offset: Integer read GetOffset;
  public
    fCaretXPix: Integer;
    property CaretX: Integer read GetCaretX write SetCaretX;
    property CaretY: Integer read GetCaretY write SetCaretY;
    procedure ShowCaret;
    procedure HideCaret;
    procedure BeginUpdate; virtual;
    procedure EndUpdate(ShowCaret: Boolean); virtual;
    Constructor Create(AOwner: TComponent); override;
    Destructor Destroy; override;
    Procedure CutToClipboard;
    Procedure CopyToClipboard;
    Procedure PasteFromClipboard;
    Procedure SelectAll;
    function CanUndo: Boolean;
    procedure Undo;
    property SelLength: Integer read FSelLength write SetSelLength;
    property SelStart: Integer read FSelStart write SetSelStart;
    property SelText: String read GetSelText write SetSelText;
  published
    property Align;
    property CharsInWindow: Integer read GetCharsInWindow;
    property Color;
    property Ctl3D;
    property DragCursor;
    property DragMode;
    property Enabled;
    property Font;
    property GutterWidth: Integer read fGutterWidth write fGutterWidth;
    property Height;
    property LeftChar: Integer read GetLeftChar write SetLeftChar;
    property Lines: TStrings read fLines write fLines;
    property LineCount: Integer read GetLineCount;
    property LinesInWindow: Integer read GetLinesInWindow;
    property LineText: String read GetLineText write SetLineText;
    property ParentColor;
    property ParentFont;
    property ParentShowHint;
    property PopupMenu;
    property ShowHint;
    property TabOrder;
    property TabStop;
    property Tag;
    property Text: String read GetText write SetText;
    property TopLine: Integer read GetTopLine write SetTopLine;
    property Visible;
    property Width;
    property OnClick;
    property OnChange: TNotifyEvent read FOnChange write FOnChange;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDrag;
    property OnEnter;
    property OnExit;
    property OnKeyDown;
    property OnKeyPress;
    property OnKeyUp;
    property OnStartDrag;
  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('mw', [TmCustomEdit]);
end;

{ TmCustomEdit }

procedure TmCustomEdit.BeginUpdate;
begin

end;

function TmCustomEdit.CanUndo: Boolean;
begin

end;

procedure TmCustomEdit.Change;
begin

end;

procedure TmCustomEdit.CopyToClipboard;
begin

end;

constructor TmCustomEdit.Create(AOwner: TComponent);
begin
  fLines := TStringList.Create;
  inherited Create(AOwner);
  Height := 150;
  Width := 100;
  Cursor := crIBeam;
  Color := clWindow;
  Font.Name := 'Courier New';
  Font.Size := 10;
  ParentFont := False;
  ParentColor := False;
  ControlStyle := ControlStyle + [csOpaque];
  Lines.Add(Self.Name);
  fTopLine := 0;
  fLeftChar := 0;
  fGutterWidth := 30;
  fCaretX := 0;
end;

procedure TmCustomEdit.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params);
end;

procedure TmCustomEdit.CreateWnd;
begin
  inherited CreateWnd;
end;

procedure TmCustomEdit.CutToClipboard;
begin

end;

destructor TmCustomEdit.Destroy;
begin
  inherited Destroy;
  fLines.Free;
end;

procedure TmCustomEdit.EMCanUndo(var Msg: TMessage);
begin
  inherited;
end;

procedure TmCustomEdit.EMUndo(var Msg: TMessage);
begin
  inherited;
end;

procedure TmCustomEdit.EndUpdate(ShowCaret: Boolean);
begin

end;

function TmCustomEdit.GetCharsInWindow: Integer;
begin
  Result := (Width - BlancOffset * 2 - fGutterWidth) div GetCharWidth;
end;

function TmCustomEdit.GetEditRect: TRect;
begin

end;

function TmCustomEdit.GetLineCount: Integer;
begin
  Result := fLines.Count;
end;

function TmCustomEdit.GetLinesInWindow: Integer;
begin
  Result := (Height - BlancOffset * 2) div GetTextHeight;
end;

function TmCustomEdit.GetLineText: String;
begin
  Result := fLines[fCaretY];
end;

function TmCustomEdit.GetBlancOffset: Integer;
begin
  Result := 2;
  if Ctl3D then Result := 4;
end;

function TmCustomEdit.GetOffset: Integer;
begin
  Result := GetBlancOffset + fGutterWidth - fLeftChar * GetCharWidth;
end;

function TmCustomEdit.GetSelText: String;
begin

end;

function TmCustomEdit.GetText: String;
begin

end;

function TmCustomEdit.GetTextHeight: Integer;
var
  DC: HDC;
  SaveFont: HFont;
  Metrics: TTextMetric;
begin
  DC := GetDC(0);
  SaveFont := SelectObject(DC, Font.Handle);
  GetTextMetrics(DC, Metrics);
  SelectObject(DC, SaveFont);
  ReleaseDC(0, DC);
  Result := Metrics.tmHeight;
end;

function TmCustomEdit.GetCharWidth: Integer;
var
  DC: HDC;
  SaveFont: HFont;
  Metrics: TTextMetric;
begin
  DC := GetDC(0);
  SaveFont := SelectObject(DC, Font.Handle);
  GetTextMetrics(DC, Metrics);
  SelectObject(DC, SaveFont);
  ReleaseDC(0, DC);
  Result := Metrics.tmAveCharWidth;
end;

function TmCustomEdit.GetTopLine: Integer;
begin
  Result := fTopLine + 1;
end;

procedure TmCustomEdit.HideCaret;
begin
  if fCaretVisible then
  begin
    if Windows.HideCaret(Handle) then fCaretVisible := False;
  end;
  PaintControl;
end;

function TmCustomEdit.HitTest(X, Y: Integer): Integer;
begin

end;

procedure TmCustomEdit.KeyDown(var Key: Word; Shift: TShiftState);
begin
  inherited;
  if Assigned(OnKeyDown) then
    OnKeyDown(Self, Key, Shift);
  case Key of
    VK_UP:
      begin
        CaretY := CaretY - 1;
        if CaretY < TopLine then TopLine := TopLine - 1;
      end;
    VK_DOWN:
      begin
        CaretY := CaretY + 1;
        if CaretY >= TopLine + LinesInWindow then TopLine := TopLine + 1;
      end;
    VK_NEXT:
      begin
        TopLine := TopLine + LinesInWindow;
        CaretY := CaretY + LinesInWindow;
      end;
    VK_PRIOR:
      begin
        TopLine := TopLine - LinesInWindow;
        CaretY := CaretY - LinesInWindow;
      end;
    VK_END: