text.pas

人制作的可输入不同类型数据的TText控件。并具有 Office 的外观(10KB)6363.zip非常著名的一组非常不错的控件。有许多图形化控件.

unit Text;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, ExtCtrls, Buttons;

type
  TSelection = record
    StartPos, EndPos: Integer;
  end;
  TGlyphKind = (gkCustom, gkDropDown);
  TValueType = (vtInteger,vtDate,vtTime,{vtDateTime,}vtString,vtCurrency,vtDouble);
  {TText}
  TText = class(TCustomEdit)
  private
    { Private declarations }
    FButton: TSpeedButton;
    FBtnControl: TWinControl;
    FButtonShortCut: TShortCut;
    FCaret: Boolean;
    FValueType    : TValueType;
    FGlyphKind: TGlyphKind;
    FMaskString   : String;
    FInputMask    : String;
    FOldValue     : String;
    FFlat        : Boolean;
    MouseInControl: Boolean;
    FAlignment    : TAlignment;
    FSingleBorder : Boolean;
    FReadOnly     : Boolean;
    FAutoAligning : Boolean;
    FFocused      : Boolean;
    FTransparent: Boolean;
    FCanvas: TControlCanvas;
    FOnButtonClick: TNotifyEvent;
    function GetButtonWidth: Integer;
    function GetButtonVisible: Boolean;
    function GetButtonEnabled: Boolean;
    function GetGlyph: TBitmap;
    function GetNumGlyphs: TNumGlyphs;
    function IsCustomGlyph: Boolean;
    procedure EditButtonClick(Sender: TObject);
    procedure SetButtonWidth(Value: Integer);
    procedure SetButtonVisible(Value: Boolean);
    procedure SetButtonEnabled(Value: Boolean);
    procedure SetValue(aValue: Variant);
    procedure SetValueType(Val: TValueType);
    procedure SetAutoAligning(Val: Boolean);
    procedure SetReadOnly(Val: Boolean);
    procedure SetGlyphKind(Value: TGlyphKind);
    procedure SetGlyph(Value: TBitmap);
    procedure SetCaret(Value: Boolean);
    procedure SetNumGlyphs(Value: TNumGlyphs);
    procedure ValidateEdit(aPos: Integer);
    procedure GetSel(var SelStart: Integer; var SelStop: Integer);
    procedure SetEditRect;
    procedure SetSel(SelStart: Integer; SelStop: Integer);
    procedure ArrowKeys(CharCode: Word; Shift: TShiftState);
    procedure DeleteKeys(CharCode: Word);
    procedure CursorDec(CursorPos: Integer);
    procedure CursorInc(CursorPos: Integer);
    procedure SetInputMask(Val: String);
    procedure SetAlignment(Val: TAlignment);
    procedure ValidIt;
    function  DeleteSelection(PStr: String; SelStart,SelStop: Integer): String;
    function  CharKeys(var CharCode: Char): Boolean;
    function  GetPriorEditChar(Offset: Integer): Integer;
    function  GetNextEditChar(Offset: Integer): Integer;
    function  GetMaskString(Val: String): String;
    function  GetText: String;
    function  InputChar(var NewChar: Char; Offset: Integer): Boolean;
    function  IsMaskChars(Const NewChar: Char; Offset: Integer; var uPos: Integer): Boolean;
    function  GetMasked: Boolean;
    function  GetValue:Variant;
    function  GetTextMargins: TPoint;
    procedure SetFlat(Value: Boolean);
    procedure SetTransparent(Value: Boolean);
    procedure NewAdjustHeight;
    procedure CMEnabledChanged (var Message: TMessage); message CM_ENABLEDCHANGED;
    procedure CMFontChanged (var Message: TMessage); message CM_FONTCHANGED;
    procedure CMMouseEnter (var Message: TMessage); message CM_MOUSEENTER;
    procedure CMMouseLeave (var Message: TMessage); message CM_MOUSELEAVE;
    procedure WMSetFocus (var Message: TWMSetFocus); message WM_SETFOCUS;
    procedure WMKillFocus (var Message: TWMKillFocus); message WM_KILLFOCUS;
    procedure WMNCCalcSize (var Message: TWMNCCalcSize); message WM_NCCALCSIZE;
    procedure WMNCPaint (var Message: TMessage); message WM_NCPAINT;
    procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
    procedure WMPaste(var Message: TMessage); message WM_PASTE;
    procedure CMEnter(var Message: TCMEnter); message CM_ENTER;
    procedure CMTextChanged(var Message: TMessage); message CM_TEXTCHANGED;
    procedure CMExit(var Message: TCMExit); message CM_EXIT;
    procedure WMLButtonDown(var Message: TWMLButtonDown); message WM_LBUTTONDOWN;
    procedure WMSize(var Message: TWMSize); message WM_SIZE;
  protected
    { Protected declarations }
    procedure ButtonClick; dynamic;
    procedure KeyDown(var Key: Word; Shift: TShiftState); override;
    procedure KeyPress(var Key: Char);  override;
    procedure Loaded; override;
    procedure CreateWnd; override;
    //procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
    procedure SetCursor(Pos: Integer);
    procedure Reset; virtual;
    function IsCombo: Boolean; dynamic;
    procedure ButtonReleased; dynamic;
    procedure CreateParams(var Params: TCreateParams); override;
  public
    { Public declarations }
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    { Published declarations }
    property ButtonWidth: Integer read GetButtonWidth write SetButtonWidth default 15;
    property Value: Variant read GetValue write SetValue;
    property ValueType : TValueType read FValueType write SetValueType;
    property InputMask: String read FInputMask write SetInputMask;
    property IsMasked: Boolean read GetMasked;
    property EditText: String read GetText;
    property AutoAligning: Boolean read FAutoAligning write SetAutoAligning default True;
    property Alignment: TAlignment read FAlignment write SetAlignment default taLeftJustify;
    property Flat: Boolean read FFlat write SetFlat;
    property Transparent: Boolean read FTransparent write SetTransparent default False;
    property SingleBorder : Boolean read FSingleBorder write FSingleBorder default False;
    property ButtonVisible: Boolean read GetButtonVisible write SetButtonVisible default False;
    property GlyphKind: TGlyphKind read FGlyphKind write SetGlyphKind default gkCustom;
    property Glyph: TBitmap read GetGlyph write SetGlyph stored IsCustomGlyph;
    property NumGlyphs: TNumGlyphs read GetNumGlyphs write SetNumGlyphs;
    property ButtonEnabled: Boolean read GetButtonEnabled write SetButtonEnabled default True;
    property Caret: Boolean read FCaret write SetCaret default True;
    property Text;
    property Anchors;
    property AutoSelect;
    property BiDiMode;
    property Color;
    property Constraints;
    property DragCursor;
    property DragKind;
    property DragMode;
    property Enabled;
    property Font;
    property ImeMode;
    property ImeName;
    property MaxLength;
    property ParentBiDiMode;
    property ParentColor;
    property ParentFont;
    property ParentShowHint;
    property PasswordChar;
    property PopupMenu;
    property ReadOnly: Boolean read FReadOnly write SetReadOnly;
    property ShowHint;
    property TabOrder;
    property TabStop;
    property Visible;
    property OnChange;
    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 OnButtonClick: TNotifyEvent read FOnButtonClick write FOnButtonClick;
  end;


implementation

uses Consts, ActnList, Clipbrd;

const
  scDefButtonShortCut = scAlt + VK_DOWN;


{------------------------------------------------------------------------}

function IsLiteralChar(const EditMask,Text: string; Offset: Integer): Boolean;
begin
  if EditMask<>'' then
    Result := ((EditMask[Offset+1]<>' ') and (EditMask[Offset+1]=Text[Offset+1]))
  else
    Result := False;
end;

function AllTrim(Str: String): String;
var
  aPos: Integer;
  TrimStr: String;
begin
  Result := '';
  Str := Trim(Str);
  TrimStr := '';
  aPos := Pos(' ',Str);
  while aPos<>0 do
  begin
    TrimStr := TrimStr + Trim(Copy(Str,1,aPos));
    Str := Trim(Copy(Str,aPos,Length(Str)));
    aPos := Pos(' ',Str);
  end;
  Result := TrimStr+Str;
end;

function DateToStrProc(FDate: TDateTime): String;
var
  iYear,iMonth,iDay: Word;
  sYear,sMonth,sDay: String;
begin
  DeCodeDate(FDate,iYear,iMonth,iDay);
  sYear := IntToStr(iYear);
  if iMonth<10 then
    sMonth := '0'+IntToStr(iMonth)
  else
    sMonth := IntToStr(iMonth);
  if iDay<10 then
    sDay := '0'+IntToStr(iDay)
  else
    sDay := IntToStr(iDay);
  Result := sYear+'年'+sMonth+'月'+sDay+'日';
end;

function TimeToStrProc(FTime: TDateTime): String;
var
  iHour,iMin,iSec,iMSec: Word;
  sHour,sMin,sSec: String;
begin
  DeCodeTime(FTime,iHour,iMin,iSec,iMSec);
  sHour := IntToStr(iHour);
  if iMin<10 then
    sMin := '0'+IntToStr(iMin)
  else
    sMin := IntToStr(iMin);
  if iSec<10 then
    sSec := '0'+IntToStr(iSec)
  else
    sSec := IntToStr(iSec);
  Result := sHour+TimeSeparator+sMin+TimeSeparator+sSec;
end;

function StrToDateProc(Str: String): TDateTime;
var
  iYear,iMonth,iDay: Word;
begin
  iYear  := StrToInt(Copy(Str,1,4));
  iMonth := StrToInt(Copy(Str,7,2));
  iDay   := StrToInt(Copy(Str,11,2));
  Result := EnCodeDate(iYear,iMonth,iDay);
end;

function CheckValue(SubStr,Str: String): Boolean;
var
  I: Integer;
begin
  Result := False;
  for I:=1 to Length(SubStr) do
  begin
    if SubStr[I]<>' ' then
      if SubStr[I]<>Str[I] then Exit;
  end;
  Result := True;
end;

function SlashStr(Str,Str1: String; Long: Integer; FStyle: Boolean): String;
var
  I: Integer;
begin
  if FStyle then
  begin
    for I:=1 to Long-Length(Str) do
     Str := Str+Str1;
  end else
  begin
    for I:=1 to Long-Length(Str) do
     Str := Str1+Str;
  end;
  Result := Str;
end;

type
  TParentControl = class(TWinControl);

procedure CopyParentImage(Control: TControl; Dest: TCanvas; FStep: Integer);
var
  I, Count, X, Y, SaveIndex: Integer;
  DC: HDC;
  R, SelfR, CtlR: TRect;
begin
  if (Control = nil) or (Control.Parent = nil) then Exit;
  Count := Control.Parent.ControlCount;
  DC := Dest.Handle;
{$IFDEF WIN32}
  with Control.Parent do ControlState := ControlState + [csPaintCopy];
  try
{$ENDIF}
    with Control do begin
      SelfR := Bounds(Left, Top, Width, Height);
      X := -Left; Y := -Top;
    end;
    { Copy parent control image }
    SaveIndex := SaveDC(DC);
    try
      SetViewportOrgEx(DC, X, Y, nil);
      IntersectClipRect(DC, 0, 0, Control.Parent.ClientWidth,
        Control.Parent.ClientHeight);
      with TParentControl(Control.Parent) do begin
        Perform(WM_ERASEBKGND, DC, 0);
        PaintWindow(DC);
      end;
    finally
      RestoreDC(DC, SaveIndex);
    end;
    { Copy images of graphic controls }
    for I := 0 to Count - 1 do begin
      if Control.Parent.Controls[I] = Control then Break
      else if (Control.Parent.Controls[I] <> nil) and
        (Control.Parent.Controls[I] is TGraphicControl) then
      begin
        with TGraphicControl(Control.Parent.Controls[I]) do begin
          CtlR := Bounds(Left, Top, Width, Height);
          if Bool(IntersectRect(R, SelfR, CtlR)) and Visible then begin
{$IFDEF WIN32}
            ControlState := ControlState + [csPaintCopy];
{$ENDIF}
            SaveIndex := SaveDC(DC);
            try
              SaveIndex := SaveDC(DC);
              SetViewportOrgEx(DC, Left + X+FStep, Top + Y, nil);
              IntersectClipRect(DC, 0, 0, Width, Height);
              Perform(WM_PAINT, DC, 0);
            finally
              RestoreDC(DC, SaveIndex);
{$IFDEF WIN32}
              ControlState := ControlState - [csPaintCopy];
{$ENDIF}
            end;
          end;
        end;
      end;
    end;
{$IFDEF WIN32}
  finally
    with Control.Parent do ControlState := ControlState - [csPaintCopy];
  end;
{$ENDIF}
end;

{------------------------------------------------------------------------}

type
  TControlHack = class(TControl);
  TEditSpeedButton = class(TSpeedButton)
  private
    FEdit: TText;
  protected
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
      X, Y: Integer); override;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
      X, Y: Integer); override;
  end;

procedure TEditSpeedButton.MouseDown(Button: TMouseButton; Shift: TShiftState;
  X, Y: Integer);
begin
  if (csDesigning in FEdit.ComponentState) then Exit;
  inherited;
  if (FState = bsDown) and (FEdit.IsCombo) then
  begin
    Update;
    Click;
  end;
end;

procedure TEditSpeedButton.MouseUp(Button: TMouseButton; Shift: TShiftState;
  X, Y: Integer);
begin
  inherited;
  FEdit.ButtonReleased;
end;

procedure TText.ValidIt;
begin
  case FValueType of
    vtDate    : begin ValidateEdit(1);ValidateEdit(6);ValidateEdit(11); end;
    vtTime    : begin ValidateEdit(1);ValidateEdit(4);ValidateEdit(7); end;
    vtDouble,
    vtCurrency: begin ValidateEdit(3);ValidateEdit(MaxLength-1); end;
    vtInteger : begin
      if AllTrim(Text)='' then
         Text := SlashStr('0',' ',MaxLength,False)
      else Text := SlashStr(AllTrim(Text),' ',MaxLength,False);
      if AllTrim(Text)='-' then
        Text := SlashStr(AllTrim(Text)+'0',' ',MaxLength,False)
      else if AllTrim(Text)='+' then
        Text := SlashStr('0',' ',MaxLength,False);
    end;
  end;
end;

procedure TText.SetValue(aValue: Variant);
begin
  case FValueType of
   vtInteger : Text := SlashStr(IntToStr(aValue),' ',MaxLength,False);
   vtDouble  : Text := SlashStr(FloatToStrF(aValue,ffFixed,10,2),' ',MaxLength,False);
   vtCurrency: Text := CurrencyString+SlashStr(FloatToStrF(aValue,ffFixed,10,2)
      ,' ',MaxLength-Length(CurrencyString),False);
   vtTime    : Text := TimeToStr(aValue);
   vtDate    : Text := DateToStrProc(aValue);
   vtString  : Text := aValue;
   //vtDateTime: Text := DateTimeToStr(Value);
  end;
  ValidIt;
  RePaint;
end;

function TText.GetValue:Variant;
Var
  Str: String;
begin
  if FValueType=vtCurrency then
    Str := AllTrim(Copy(Text,Pos(CurrencyString,Text)
               +Length(CurrencyString),Length(Text)))
  else
    Str := AllTrim(Text);
  if (FValueType=vtCurrency) or (FValueType=vtDouble) then
  begin
    if Length(Str)=Pos('.',Str) then
      Str := Str+'00'
  end;
  if (FValueType=vtInteger) then
    if Str='' then Str := '0';
  case FValueType of
   vtInteger : Result := StrToInt(Str);
   vtDouble  : Result := StrToFloat(Str);
   vtCurrency: Result := StrToFloat(Str);
   vtTime    : Result := StrToTime(Str);
   vtDate    : Result := StrToDateProc(Str);
   vtString  : Result := Text;
   //vtDateTime: Result := StrToDateTime(Text);
  end;
end;

procedure TText.GetSel(var SelStart: Integer; var SelStop: Integer);
begin
  SendMessage(Handle, EM_GETSEL, Integer(@SelStart), Integer(@SelStop));
end;

procedure TText.SetSel(SelStart: Integer; SelStop: Integer);
begin
  SendMessage(Handle, EM_SETSEL, SelStart, SelStop);
end;

procedure TText.SetEditRect;
var
  R: TRect;
begin
  if HandleAllocated then
  begin
    if FBtnControl.Visible then
      R := Rect(0, 0, ClientWidth - FButton.Width - 2, ClientHeight + 1)
    else
      R := Rect(0, 0, ClientWidth,ClientWidth);
    SendMessage(Handle, EM_SETRECTNP, 0, LongInt(@R));
  end;
end;

procedure TText.SetValueType(Val: TValueType);
var
  aMaskStr: String;
begin
  if FValueType<>Val then
  begin
    FValueType := Val;
    case FValueType of
      vtInteger: aMaskStr := '99999999';
      vtDate: aMaskStr := '9999'+'年'+'99'+'月'+'99'+'日';
      vtTime: aMaskStr := '99'+TimeSeparator+'99'+TimeSeparator+'99';
      //vtDateTime: aMaskStr := '9999'+DateSeparator+'99'+DateSeparator+'99'+'/'+'99'+TimeSeparator+'99'+TimeSeparator+'99';
      vtString: aMaskStr := '';
      vtCurrency: aMaskStr := CurrencyString+'999999999.99';
      vtDouble: aMaskStr := '999999999.99';
    end;
    SetInputMask(aMaskStr);
  end;
end;

constructor TText.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FAutoAligning := True;
  FAlignment := taLeftJustify;
  FValueType := vtString;
  Ctl3D := True;
  ParentCtl3D := False;
  FSingleBorder := False;
  FFlat := False;

  FBtnControl := TWinControl.Create(nil);
  FBtnControl.Align := alRight;
  FBtnControl.Cursor := crArrow;
  TControlHack(FBtnControl).Color := clBtnFace;
  FBtnControl.Parent := Self;
  FBtnControl.Visible := False;

  FButton := TEditSpeedButton.Create(nil);
  TEditSpeedButton(FButton).FEdit := Self;
  FButton.OnClick := EditButtonClick;
  FButton.Align := alRight;
  FButton.Parent := FBtnControl;
  FButton.Transparent := True;
  FButtonShortCut := scDefButtonShortCut;
  FCaret := True;
  SetButtonWidth(16);
end;

destructor TText.Destroy;
begin
  FCanvas.Free;
  inherited Destroy;
end;

procedure TText.EditButtonClick(Sender: TObject);
begin
  ButtonClick;
end;

procedure TText.CursorDec(CursorPos: Integer);
var
  nuPos: Integer;
begin