Unit FloatEdit;

Interface

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

Type
  TFloatEdit = Class (TCustomMemo)
  Private
    FDecimals    : integer;
    FMaxLength   : integer;
    FormatString : string;
    DecimalPos   : integer;
    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

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


Procedure TFloatEdit.SetDecimals (Value: integer);
Var
  i : integer;
Begin
  If (Value >= 0) and (Value < FMaxLength - 1) Then
    FDecimals := Value;
  If Value <> 0 Then
  Begin
    FormatString := '#,##0.';
    For i := 1 to FDecimals Do
      FormatString := FormatString + '0'
  End
  Else
    FormatString := '#,##0';
  MaxLength := MaxLength;
  Reformat
End;


Procedure TFloatEdit.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 TFloatEdit.StripCommas (AString: string) : string;
Var
  StringValue: Extended;
  ErrorPos    : integer;
  HaveDecimal:boolean;
  i:integer;
Begin
  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;
  Val (AString, StringValue, ErrorPos);
  If ErrorPos > 0 Then
    Result := '0'
  Else
  Begin
    if not HaveDecimal then
    begin
      AString:=AString+'.';
      For I:=0 to FDecimals do
        AString:=AString+'0';
    end else
    begin
      Insert (DecimalSeparator, AString, Length (AString) - FDecimals + 1);
    end;
    Result := AString
  End
End;


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


Procedure TFloatEdit.CMEnter (Var Message: TCMGotFocus);
var
  AString:string;
Begin
  AString:=Text;
  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 TFloatEdit.CMExit (Var Message: TCMLostFocus);
var
  AString:string;
Begin
  AString:=Text;
  if Pos (DecimalSeparator,AString)=0 then
    AString:=AString+'.';
  While Length(AString)-Pos (DecimalSeparator,AString)<FDecimals do
    AString:=AString+'0';
  Text:=AString;
  reformat;
  //Inherited;
End;


Procedure TFloatEdit.KeyDown (Var Key: Word; Shift: TShiftState);
Var
  CursorPos : integer;
  Buffer    : string;
Begin
  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 TFloatEdit.KeyPress (Var Key: char);
Var
  Buffer    : string;
  CursorPos : integer;
Begin
  if key=#13 then begin Inherited KeyPress (Key);Exit; end;
  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 TFloatEdit.GetTextAsFloat;
var
  AMessage:TCMLostFocus;
Begin
  CMExit(AMessage);
  Result := StrToFloat (StripCommas (Text))
End;


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


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


End.