Unit CurrencyEdit;

Interface

Uses
  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Forms,
    Dialogs, StdCtrls, Menus;

Type
  TCurrencyEdit = Class (TCustomMemo)
  Private
    FDecimals    : integer;
    FMaxLength   : integer;
    FormatString : string;
    DecimalPos   : integer;
    FReadOnly: Boolean;
    Procedure SetDecimals (Value: integer);
    Procedure SetMaxLength (Value: integer);
    Function StripCommas (AString: string) : string;
    Procedure Reformat;
    Procedure CMEnter (Var Message: TCMGotFocus); Message CM_ENTER;
    Procedure CMExit (Var Message: TCMLostFocus); Message CM_Exit;
    Function GetTextAsFloat : Extended;
    Procedure SetTextAsFloat (Value: Extended);
  Protected
    Procedure KeyDown (Var Key: Word; Shift: TShiftState);Override;
    Procedure KeyPress (Var Key: char);Override;
  Public
    Constructor Create (AOwner: TComponent);Override;
  Published
    Property MaxLength : integer Read FMaxLength Write SetMaxLength;
    Property Decimals : integer Read FDecimals Write SetDecimals;
    Property Value : Extended Read GetTextAsFloat Write SetTextAsFloat;
    Property Alignment Default taRightJustify;
    Property BorderStyle;
    Property Color;
    Property Ctl3D;
    Property DragCursor;
    Property DragMode;
    Property Enabled;
    Property Font;
    Property HideSelection;
    Property ParentColor;
    Property ParentCtl3D;
    Property ParentFont;
    Property ParentShowHint;
    Property PopupMenu;
    Property ReadOnly;
    Property ShowHint;
    Property TabOrder;
    Property TabStop;
    Property Visible;
    Property OnChange;
    Property OnClick;
    Property OnDblClick;
    Property OnDragDrop;
    Property OnDragOver;
    Property OnEndDrag;
    Property OnEnter;
    Property OnExit;
    Property OnKeyDown;
    Property OnKeyPress;
    Property OnKeyUp;
    Property OnMouseDown;
    Property OnMouseMove;
    Property OnMouseUp;
  End;

Procedure Register;

Implementation

var
  HaveGetFloat:Boolean;

Constructor TCurrencyEdit.Create (AOwner: TComponent);
Begin
  Inherited Create (AOwner);
  WantReturns := False;
  Height := 24;
  Width := 120;
  Alignment := taRightJustify;
  DecimalPos := 0;
  FMaxLength := 16;
  Decimals := 2
End;


Procedure TCurrencyEdit.SetDecimals (Value: integer);
Begin
  If Value<>2 then
    Exit;
  FDecimals := Value;
  FormatString := '￥#,##0.00';
  MaxLength := MaxLength;
  Reformat
End;


Procedure TCurrencyEdit.SetMaxLength (Value: integer);
Begin
  If (Value < 20) and (Value > FDecimals + 1) Then
    FMaxLength := Value;
  If (FMaxLength - FDecimals - 1) mod 4 = 0 Then
    Dec (FMaxLength)
End;


Function TCurrencyEdit.StripCommas (AString: string) : string;
Var
  StringValue: Extended;
  ErrorPos    : integer;
  HaveDecimal:boolean;
Begin
  HaveDecimal:=False;
  While (Pos (ThousandSeparator, AString) > 0) Do
    delete(AString, Pos (ThousandSeparator, AString), 1);
  While (Pos (DecimalSeparator, AString) > 0) Do
  begin
    delete (AString, Pos (DecimalSeparator, AString), 1);
    HaveDeciMal:=True;
  end;
  While (Pos ('￥', AString) > 0) Do
    delete (AString, Pos ('￥', AString), 2);
  Val (AString, StringValue, ErrorPos);
  If ErrorPos > 0 Then
    Result := '0'
  Else
  Begin
    if not HaveDecimal then
       AString:=AString+'.00'
    else
       Insert (DecimalSeparator, AString, Length (AString) - 1);
    Result := AString
  End
End;


Procedure TCurrencyEdit.Reformat;
Begin
  Text := FormatFloat (FormatString, StrToFloat (StripCommas (Text)))
End;


Procedure TCurrencyEdit.CMEnter (Var Message: TCMGotFocus);
var
  AString:string;
Begin
  HaveGetFloat:=False;
  AString:=Text;
  While (Pos ('￥', AString) > 0) Do
    Delete (AString, Pos ('￥', AString), 2);
  While (Pos (ThousandSeparator, AString) > 0) Do
    Delete(AString, Pos (ThousandSeparator, AString), 1);
  While ((Pos(Copy(AString,Length(AString),1),'0.')>0) ) Do
  begin
    if Copy(AString,Length(AString),1)='.' then
    begin
      Delete(AString, Length(AString), 1);
      Break;
    end;
    Delete(AString, Length(AString), 1);
    if AString='' then
    begin
      AString:='0';
      Break;
    end;
  end;
  Text:=AString;
  SelectAll;
  Inherited;
End;

Procedure TCurrencyEdit.CMExit (Var Message: TCMLostFocus);
var
  AString:string;
Begin
  AString:=Text;
  if Pos (DecimalSeparator,AString)>0 then
  begin
    if Length(AString)-Pos (DecimalSeparator,AString)<=1 then
      AString:=AString+'0'
  end
  else
    AString:=AString+'.00';
  Text:=AString;
  reformat;
  HaveGetFloat:=True;
  Inherited;
End;


Procedure TCurrencyEdit.KeyDown (Var Key: Word; Shift: TShiftState);
Var
  CursorPos : integer;
  Buffer    : string;
Begin
  if ReadOnly then Exit;
  Inherited KeyDown (Key, Shift);
  If Key = VK_DELETE Then
  Begin
    Buffer := Text;
    CursorPos := Length (Buffer) - SelStart - SelLength;
    if SelLength<>0 then
    begin
      Delete(Buffer, SelStart+1, SelLength);
      Key:=0;
      Text := Buffer;
      SelStart := Length (Text) - CursorPos;
      Exit;
    end
    else begin
      Delete(Buffer, SelStart+1, 1);
      Key:=0;
      Text := Buffer;
      SelStart := Length (Text) - CursorPos+1 ;
      Exit;
    end;
  end;
End;

Procedure TCurrencyEdit.KeyPress (Var Key: char);
Var
  Buffer    : string;
  CursorPos : integer;
Begin
  if ReadOnly then Exit;
  Inherited KeyPress (Key);      //if Key=#13 then Exit; 
  Buffer := Text;
  CursorPos := Length (Buffer) - SelStart - SelLength;
  if SelLength<>0 then
    Delete(Buffer, SelStart+1, SelLength);
  if Key=#8 then
  begin
    Delete (Buffer, Length (Buffer) - CursorPos, 1);
    Text := Buffer;
    SelStart := Length (Text) - CursorPos;
    Key:=#0;
    Exit;
  end;
  if not (Key in ['0' .. '9','.','-']) then
  begin
    Key:=#0;
    Exit;
  end;
  if (Pos (DecimalSeparator, Buffer) > 0) then
  begin
    if (Key='.') or ((Cursorpos<FDecimals+1)
    and (Length(Buffer)-Pos (DecimalSeparator, Buffer)>=FDecimals)) then
    begin
      Key:=#0;
      Exit;
    end;
  end;
  if Key='.' then
  begin
    if CursorPos>FDecimals then
    begin
      Key:=#0;
      Exit;
    end;
  end;
  if  Length(Buffer)>=FMaxLength then
  begin
    Key:=#0;
    Exit;
  end;
  if Key='-' then
  begin
    if CursorPos<>Length(Buffer) then
    begin
      Key:=#0;
      Exit;
    end;
  end;
  Insert (Key, Buffer, Length (Buffer) - CursorPos + 1);
  Text := Buffer;
  SelStart := Length (Text) - CursorPos;
  Key:=#0;
End;

Function TCurrencyEdit.GetTextAsFloat;
var
  AMessage:TCMLostFocus;
  //B, T: Boolean;
Begin
  //B:=False; T:=False;
  if not HaveGetFloat then
    //if Focused then begin B:=True; T:=True; end;
    CMExit(AMessage);
    //if B and T then begin CMEnter(AMessage); T:=False; end;
  Result := StrToFloat (StripCommas (Text))
End;


Procedure TCurrencyEdit.SetTextAsFloat (Value: Extended);
Begin
  Text := FormatFloat (FormatString, Value)
End;


Procedure Register;
Begin
  RegisterComponents ('MyVcl', [TCurrencyEdit])
End;


End.