| Kaf_Dağı | 18 Mart 2015 14:02 |
Sadece rakam kullanabileceğiniz şık bir edit component
Kod:
unit PBNumEdit;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls;
const
PB_SETTINGCHANGE = WM_USER + 147;
type
TNumberFormat = (Standard, Thousands, Scientific, Engineering);
TPBNumEdit = class(TCustomEdit)
private
FAlignment: TAlignment;
FDecimals: ShortInt;
FEnter, FParentColor : Boolean;
FInvalidEntry: TNotifyEvent;
FMaxValue: Extended;
FMinValue: Extended;
FNumberFormat : TNumberFormat;
FVersion: String;
FDisabledColor, FEnabledColor : TColor;
OldDecimalSep, OldThousandSep : Char;
FOnClear : TNotifyEvent;
function FormatText(Value: Extended): string;
function GetAsCurrency: Currency;
function GetAsFloat: Extended;
function GetAsInteger: Integer;
function GetValue: Extended;
function HookMainProc(var Message: TMessage) : Boolean;
function Remove1000(Num : string): string;
function ReplaceSeparators(Num : string) : string;
procedure DeleteKey(Key: Word);
procedure DeleteSelection;
procedure SetAlignment(Value: TAlignment);
procedure SetAsCurrency(Value: Currency);
procedure SetAsFloat(Value: Extended);
procedure SetAsInteger(Value: Integer);
procedure SetColor(Value : TColor);
procedure SetDisabledColor(Value : TColor);
procedure SetDecimals(Value: ShortInt);
procedure SetMaxValue(Value: Extended);
procedure SetMinValue(Value: Extended);
procedure SetNumberFormat(Value: TNumberFormat);
procedure SetParentColor(Value : Boolean);
procedure SetValue(Value: Extended);
procedure SetVersion(Value: String);
procedure WMClear(var Msg : TMessage); message WM_CLEAR;
procedure WMCut(var Message: TMessage); message WM_CUT;
procedure WMCopy(var Message: TMessage); message WM_COPY;
procedure WMGetDlgCode(var Msg : TWMGetDlgCode); message WM_GETDLGCODE;
procedure WMPaste(var Message: TMessage); message WM_PASTE;
procedure WMSettingchange(var Message: TMessage); message PB_SETTINGCHANGE;
procedure CMPARENTCOLORCHANGED(var M:TMessage); message CM_PARENTCOLORCHANGED;
protected
procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
procedure DoEnter; override;
procedure DoExit; override;
procedure InvalidEntry;
procedure KeyDown(var Key: Word; Shift: TShiftState); override;
procedure KeyPress(var Key: Char); override;
procedure Keyup(var Key: Word; Shift: TShiftState); override;
procedure SetEnabled(Value : Boolean); override;
procedure Loaded; override;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure CreateParams(var Params: TCreateParams); override;
property AsCurrency: Currency read GetAsCurrency write SetAsCurrency;
property AsFloat: Extended read GetAsFloat write SetAsFloat;
property AsInteger: Integer read GetAsInteger write SetAsInteger;
published
property Alignment: TAlignment read FAlignment write SetAlignment;
{$IFNDEF VER100} property Anchors; {$ENDIF}
property AutoSelect;
property AutoSize;
property BorderStyle;
property Color : TColor read FEnabledColor write SetColor default clWindow;
property DisabledColor : TColor read FDisabledColor
write SetDisabledColor default clBtnFace;
property Enabled : Boolean read GetEnabled
write SetEnabled default True;
property Ctl3D;
property Decimals: ShortInt read FDecimals write SetDecimals;
property DragCursor;
property DragMode;
property Font;
property HideSelection;
property MaxLength;
property MaxValue: Extended read FMaxValue write SetMaxValue;
property MinValue: Extended read FMinValue write SetMinValue;
property NumberFormat: TNumberFormat read FNumberFormat write SetNumberFormat;
property OnChange;
property OnClear : TNotifyEvent read FOnClear write FOnClear;
property OnClick;
property OnDblClick;
property OnDragDrop;
property OnDragOver;
property OnEndDrag;
property OnEnter;
property OnExit;
property OnInvalidEntry: TNotifyEvent read FInvalidEntry write FInvalidEntry;
property OnKeyDown;
property OnKeyPress;
property OnKeyUp;
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
property OnStartDrag;
property ParentColor : Boolean read FParentColor
write SetParentColor default False;
property ParentCtl3D;
property ParentFont;
property ParentShowHint;
property PopupMenu;
property ReadOnly;
property ShowHint;
property TabOrder;
property TabStop;
property Value: Extended read GetValue write SetValue;
property Version: String read FVersion write SetVersion stored False;
property Visible;
property Align;
end;
procedure Register;
implementation
uses Clipbrd;
constructor TPBNumEdit.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
Width := 100;
FAlignment := taRightJustify;
FDecimals := -1;
FEnter := False;
FMaxValue := 0;
FMinValue := 0;
FNumberFormat := Standard;
FVersion := '8.50.00.00';
OldDecimalSep := DecimalSeparator;
OldThousandSep := ThousandSeparator;
Value := 0;
Text := FormatText(Value);
inherited Enabled := True;
inherited Color := clWindow;
FEnabledColor := clWindow;
FDisabledColor := clBtnFace;
Application.HookMainWindow(HookMainProc);
end;
procedure TPBNumEdit.Loaded;
begin
inherited;
if Enabled then inherited Color := FEnabledColor
else inherited Color := FDisabledColor;
end;
procedure TPBNumEdit.CreateParams(var Params: TCreateParams);
const
Alignments: array[TAlignment] of Word = (ES_LEFT, ES_RIGHT, ES_CENTER);
begin
inherited CreateParams(Params);
Params.Style := Params.Style or ES_MULTILINE or Alignments[FAlignment];
end;
destructor TPBNumEdit.Destroy;
begin
Application.UnHookMainWindow(HookMainProc);
inherited;
end;
procedure TPBNumEdit.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
if (Button = mbLeft) or (ssLeft in Shift) then
begin
if FEnter = True then
begin
FEnter := False;
if AutoSelect then SelectAll;
end;
end;
inherited MouseDown(Button, Shift, X, Y);
end;
procedure TPBNumEdit.DoEnter;
begin
inherited DoEnter;
if csLButtonDown in ControlState then FEnter := True;
if AutoSelect then SelectAll;
end;
procedure TPBNumEdit.DoExit;
begin
Text := FormatText(Value);
if ((FMinValue <> 0) or (FMaxValue <> 0))
and ((Value < FMinValue) or (Value > FMaxValue)) then InvalidEntry
else inherited DoExit;
end;
procedure TPBNumEdit.KeyDown(var Key: Word; Shift: TShiftState);
begin
inherited KeyDown(Key, Shift);
FEnter := False;
if not ReadOnly then
begin
if Key in [VK_DELETE, VK_BACK] then
begin
if SelLength > 0 then DeleteSelection
else DeleteKey(Key);
Key := 0;
end;
end;
end;
procedure TPBNumEdit.KeyPress(var Key: Char);
var
P, D, E : Integer;
N, NE : Boolean;
begin
inherited KeyPress(Key);
if ReadOnly or (Key in [#3, #22, #24]) then exit;
if not (Key in ['0'..'9', DecimalSeparator, '-', 'e', 'E'])
or ((Key = DecimalSeparator) and (FDecimals = 0)) then
begin
MessageBeep(0);
Key := #0;
Exit;
end;
P := SelStart;
D := pos(DecimalSeparator, Text);
E := pos('E', Text);
if Key = 'e' then Key := 'E';
if Key in [DecimalSeparator, 'E'] then SelLength := 0
else DeleteSelection;
N := (Text[1] = '-');
NE := (pos('-', copy(Text, E + 1, length(Text) - E)) <> 0) and (E <> 0);
if N and (SelStart = 0) then SelStart := 1;
if NE and (Selstart = E + 1) then SelStart := SelStart + 1;
if Key = '-' then
begin
if (P < E) or (E = 0) then
begin
if not N then
begin
Text := '-' + Text;
SelStart := P + 1;
end
else
begin
Text := Copy(Text, 2, Length(Text) - 1);
SelStart := P - 1;
end;
end
else
begin
if not NE then
begin
Text := copy(Text, 1, E) + '-' + copy(Text, E + 1, Length(Text) - E);
SelStart := P + 1;
end
else
begin
Text := copy(Text, 1, E) + copy(Text, E + 2, Length(Text) - E - 1);
SelStart := P - 1;
end;
end;
Key := #0;
exit;
end;
if Key = DecimalSeparator then
begin
if D <> 0 then
begin
Selstart := D;
Key := #0;
end
else if FDecimals < 0 then
begin
if E <> 0 then Selstart := E - 1
else Selstart := Length(Text);
end;
exit;
end
else if Key = 'E' then
begin
if E = 0 then SelStart := Length(Text)
else
begin
SelStart := E;
Key := #0;
end;
Exit;
end;
if (SelStart <= 2) and (Copy(Text, 2, 1) = '0') and N then
begin
SelStart := 1;
SelLength := 1;
end
else if (SelStart <= 1) and (Copy(Text, 1, 1) = '0') then
begin
SelStart := 0;
SelLength := 1;
end
else if (SelStart = E) and (E <> 0) and (copy(Text,E + 1, 1) = '0')
then SelLength := 1
else if (SelStart >= E) and (E <> 0) then
begin
if Abs(StrToInt(Copy(Text, E + 1, SelStart - E) + Key + Copy(Text, SelStart + 1, 99))) > 4932 then
begin
MessageBeep(0);
Key := #0;
end;
end
else if FDecimals > 0 then
begin
if (SelStart = D + FDecimals) then
begin
MessageBeep(0);
Key := #0;
end
else if SelStart >= D then SelLength := 1
else if SelStart < D - 1 then SelLength := 0;
end;
end;
procedure TPBNumEdit.Keyup(var Key: Word; Shift: TShiftState);
var
Numsep, NumSep0, SelStart0, X, D, N, N0 : integer;
Text0 : string;
begin
inherited KeyUp(Key, Shift);
if (SelLength > 0) then exit;
if NumberFormat <> Thousands then exit;
D := pos(DecimalSeparator, Text);
SelStart0 := SelStart;
NumSep := 0;
NumSep0 := 0;
Text0 := FormatText(AsFloat);
for X := 1 to length(Text0) do
if Text0[X] = ThousandSeparator then inc(NumSep0);
for X := 1 to length(Text) do
if Text[X] = ThousandSeparator then inc(NumSep);
N := pos(ThousandSeparator, Text);
N0 := pos(ThousandSeparator, Text0);
if (NumSep <> NumSep0) or (N <> N0) or (Key in [32, 13]) then
begin
Text := Text0;
Selstart := SelStart0 + NumSep0 - NumSep;
if (pos(DecimalSeparator, Text) <> 0) and (D = 0) then Selstart := Selstart + 1
else if (D <> 0) and (pos(DecimalSeparator, Text) = 0) then Selstart := Selstart - 1;
if Copy(Text, Selstart + 1, 1) = ThousandSeparator then Selstart := Selstart + 1;
end;
end;
function TPBNumEdit.GetAsCurrency: Currency;
begin
Result := StrToCurr(Remove1000(Text));
end;
function TPBNumEdit.GetAsFloat: Extended;
begin
Result := StrToFloat(Remove1000(Text));
end;
function TPBNumEdit.GetAsInteger: Integer;
begin
Result := Trunc(StrToFloat(Remove1000(Text)));
end;
function TPBNumEdit.GetValue: Extended;
begin
Result := StrToFloat(Remove1000(Text));
end;
procedure TPBNumEdit.SetAsCurrency(Value: Currency);
begin
if Text <> FormatText(Value) then Text := FormatText(Value);
end;
procedure TPBNumEdit.SetAsFloat(Value: Extended);
begin
if Text <> FormatText(Value) then Text := FormatText(Value);
end;
procedure TPBNumEdit.SetAsInteger(Value: Integer);
begin
if Text <> FormatText(Value) then Text := FormatText(Value);
end;
procedure TPBNumEdit.SetAlignment(Value: TAlignment);
var
SelSt, SelLe : integer;
begin
if FAlignment <> Value then
begin
SelSt := SelStart;
SelLe := SelLength;
FAlignment := Value;
RecreateWnd;
SelStart := SelSt;
SelLength := SelLe;
end;
end;
procedure TPBNumEdit.SetColor(Value : TColor);
begin
if FEnabledColor <> Value then
begin
FEnabledColor := Value;
if Enabled then inherited Color := Value;
if (Parent <> nil) and (FEnabledColor <> Parent.Brush.Color)
then FParentColor := False;
end;
end;
procedure TPBNumEdit.SetDisabledColor(Value : TColor);
begin
if FDisabledColor <> Value then
begin
FDisabledColor := Value;
if (not Enabled) then inherited Color := Value;
end;
end;
procedure TPBNumEdit.SetEnabled(Value : Boolean);
begin
inherited;
if Enabled then inherited Color := FEnabledColor
else inherited Color := FDisabledColor;
end;
procedure TPBNumEdit.SetDecimals(Value: ShortInt);
var Value0 : ShortInt;
begin
Value0 := Value;
if FDecimals <> Value0 then
begin
if Value0 < 0 then Value0 := -1
else if Value0 > 14 then Value0 := 14;
if (Value0 > MaxLength - 2) and (MaxLength > 0) then Value0 := maxlength - 2;
FDecimals := Value0;
Text := FormatText(AsFloat);
end;
end;
procedure TPBNumEdit.SetMaxValue(Value: Extended);
begin
if (FMaxValue <> Value) and (Value >= FminValue) then
begin
FMaxValue := Value;
end;
end;
procedure TPBNumEdit.SetMinValue(Value: Extended);
begin
if (FMinValue <> Value) and (Value <= FmaxValue) then
begin
FMinValue := Value;
end;
end;
procedure TPBNumEdit.SetParentColor(Value : Boolean);
begin
if FParentColor <> Value then
begin
FParentColor := Value;
if FParentColor and (Parent <> nil) then FEnabledColor := Parent.Brush.Color;
SetEnabled(Enabled);
end;
end;
procedure TPBNumEdit.SetValue(Value: Extended);
begin
if csDesigning in ComponentState then
begin
if (Value > FMaxValue) and ((FMaxValue <> 0) or (FMinValue <> 0)) then InvalidEntry;
if (Value < FMinValue) and ((FMaxValue <> 0) or (FMinValue <> 0)) then InvalidEntry;
end;
if Text <> FormatText(Value) then Text := FormatText(Value);
end;
procedure TPBNumEdit.DeleteKey(Key: Word);
var
P, D, E: Integer;
N: Boolean;
str0 : string;
begin
D := pos(DecimalSeparator, Text);
E := pos('E', Text);
if E = 0 then E := length(Text) + 1;
if Key = VK_DELETE then
begin
P := SelStart + 1;
if P > Length(Text) then Exit;
if Text[P] in [ThousandSeparator, DecimalSeparator, 'E'] then inc(P);
end
else
begin
P := SelStart;
if P = 0 then Exit;
if Text[P] in [ThousandSeparator, DecimalSeparator, 'E'] then dec(P);
end;
N := (Pos('-', Text) > 0);
if (P = 0) or (P > Length(Text)) then exit;
str0 := '';
if (P > D) and (D <> 0) and ((P < E) or (E = 0)) then
begin
if FDecimals > 0 then str0 := '0';
Text := Copy(Text, 1, P - 1) + Copy(Text, P + 1,E - P - 1)
+ str0 + Copy(Text, E, length(Text) - E + 1);
SelStart := P - 1;
end
else if (P = 1) and N then
begin
Text := Copy(Text, 2, Length(Text) - 1);
if Text = '' then Text := '0';
end
else if (P = 1) and ((P = D - 1) or (P = E - 1) or (P = length(Text))) then
begin
Text := '0' + Copy(Text, 2, Length(Text) - 1);
SelStart := 1;
if N then Text := '-' + Text;
end
else if P > 0 then
begin
Text := Copy(Text, 1, P - 1) + Copy(Text, P + 1, Length(Text) - P);
SelStart := P - 1;
if ((FNumberFormat = Scientific) or (FNumberFormat = Engineering))
and (Text[length(Text)] = 'E') then Text := Text + '0';
end;
end;
procedure TPBNumEdit.DeleteSelection;
var
X, Y, Z: Integer;
begin
if SelLength = 0 then exit;
if SelText = Text then
begin
Text := FormatText(0);
exit;
end;
Y := Length(Remove1000(SelText));
if pos(DecimalSeparator, SelText) <> 0 then dec(Y);
Z := Length(SelText);
SelStart := SelStart + Z;
for X:= 1 to Y do
begin
DeleteKey(VK_BACK);
end;
end;
procedure TPBNumEdit.InvalidEntry;
begin
if not (csLoading in ComponentState) then
begin
if Assigned(FInvalidEntry) then FInvalidEntry(Self)
else
begin
if Value < FMinValue then Value := FMinValue
else if Value > FMaxValue then Value := FMaxValue;
MessageBeep(0);
if CanFocus and (not (csDesigning in ComponentState)) then SetFocus;
end;
end;
end;
procedure TPBNumEdit.SetVersion(Value: String);
begin
{ Read only! }
end;
procedure TPBNumEdit.WMCopy(var Message: TMessage);
begin
ClipBoard.AsText := Remove1000(Seltext);
end;
procedure TPBNumEdit.WMCut(var Message: TMessage);
begin
ClipBoard.AsText := Remove1000(Seltext);
DeleteSelection;
end;
procedure TPBNumEdit.WMPaste(var Message: TMessage);
var
X: integer;
S: String;
W: Word;
begin
DeleteSelection;
S := Clipboard.AsText;
for X := 1 to Length(S) do
begin
W := Ord(S[X]);
Perform(WM_CHAR, W, 0);
end;
end;
procedure TPBNumEdit.SetNumberFormat(Value: TNumberFormat);
begin
if FNumberFormat <> Value then FNumberFormat := Value;
Text := FormatText(AsFloat);
end;
function TPBNumEdit.ReplaceSeparators(Num : string) : string;
var
t : integer;
begin
Result := Num;
for t := 1 to Length(Result) do
begin
if Result[t] = OldDecimalSep then Result[t] := DecimalSeparator
else if Result[t] = OldThousandSep then Result[t] := ThousandSeparator;
end;
OldDecimalSep := DecimalSeparator;
OldThousandSep := ThousandSeparator;
end;
function TPBNumEdit.Remove1000(Num : string): string;
var
t : integer;
begin
if (OldDecimalSep <> DecimalSeparator)
or (OldThousandSep <> ThousandSeparator)
then Num := ReplaceSeparators(Num);
Result := '';
for t :=1 to length(Num) do
begin
if Num[t] <> ThousandSeparator then Result := Result + Num[t];
end;
if Result = '' then Result := '0';
if Result = '-' then Result := '-0';
end;
function TPBNumEdit.FormatText(Value: Extended) : string;
var
e0, E, D, NN, t, FD : integer;
a : extended;
Formatmask : string;
begin
if (FNumberFormat = Engineering) and (Value <> 0) then
begin
e0 := trunc(ln(abs(Value)) / ln(10) / 3) * 3;
Result := 'E' + inttostr(e0);
a := Value / StrToFloat('1' + Result);
FD := 14;
if a > 9 then dec(FD);
if a > 99 then dec(FD);
if (FD > FDecimals) and (FDecimals <> -1) then FD := FDecimals;
if FDecimals < 0 then Result := formatfloat('0.' + StringOfChar('#',FD), a) + Result
else if FDecimals = 0 then Result := formatfloat('0', a) + Result
else Result := formatfloat('0.' + StringOfChar('0',FD), a) + Result;
end
else
begin
FormatMask := '0';
if FNumberFormat = Thousands then FormatMask := ',' + FormatMask;
if FDecimals > 0 then FormatMask := FormatMask + '.' + StringOfChar('0', FDecimals)
else if FDecimals < 0 then FormatMask := FormatMask + '.' + StringOfChar('#', 14);
if FNumberFormat > Thousands then FormatMask := FormatMask + 'E-';
Result := FormatFloat(FormatMask, Value);
E := pos('E',Result);
if E = 0 then
begin
D := pos(DecimalSeparator, Result);
if (D <> 0) then
begin
NN := 0;
for t := 1 to D do if (Result[t] in ['0'..'9'] = True) then inc(NN);
if (FDecimals = -1) then
begin
if FNumberFormat = Thousands then Result := FormatFloat(',0.' + StringOfChar('#',15 - NN),Value)
else if FDecimals <> -1 then Result := FormatFloat('0.' + StringOfChar('#',15 - NN),Value);
end
else if (FDecimals > 15 - NN) then
begin
if FNumberFormat = Thousands then Result := FormatFloat(',0.' + StringOfChar('0',15 - NN),Value)
else if FDecimals <> -1 then Result := FormatFloat('0.' + StringOfChar('0',15 - NN),Value);
Result := Result + StringOfChar('0', Fdecimals -15 + NN);
end;
end;
end;
end;
end;
// Trap when decimalseparator or thousandseparator has changed.
function TPBNumEdit.HookMainProc(var Message: TMessage) : Boolean;
begin
Result := False;
if Message.Msg = WM_SETTINGCHANGE
then PostMessage(Self.Handle, PB_SETTINGCHANGE, 0, 0);
end;
procedure TPBNumEdit.WMSettingchange(var Message: TMessage);
begin
Text := ReplaceSeparators(Text);
end;
procedure TPBNumEdit.CMPARENTCOLORCHANGED(var M:TMessage);
begin
if FParentColor and (Parent <> nil) then FEnabledColor := Parent.Brush.Color;
if Parent <> nil then Invalidate;
SetEnabled(Enabled);
end;
procedure TPBNumEdit.WMClear(var Msg : TMessage);
begin
if Assigned(FOnClear) then FOnClear(Self)
else DeleteSelection;
end;
procedure TPBNumEdit.WMGetDlgCode(var Msg: TWMGetDlgCode);
begin
Msg.Result := DLGC_WANTCHARS or DLGC_WANTARROWS;
end;
procedure Register;
begin
RegisterComponents('Ramazan', [TPBNumEdit]);
end;
end.
|
