网站 › 『 编程之美 』 › 初来乍到，贡献一控件吧。前两天写的。

虫虫 发表于 2009-10-31 18:04:25

初来乍到，贡献一控件吧。前两天写的。

初来乍到，贡献一控件吧。前两天写的。

unit EditEx;

inte**ce

uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Forms, Controls,
StdCtrls, Menus, Themes, Dialogs;

type
TValueType = (vtString, vtNumberOnly, vtFloat);
TPaintHintTextEvent = procedure(Sender: TObject; Canvas: TCanvas;
    var EnableAfterPaint: Boolean) of object;

TCustomEditEx = class;
TValueSetting = class(TPersistent)
private
    FEditControl: TCustomEditEx;
    FValueType: TValueType;             //数据类型

    FShowThousands: Boolean;            //千位分隔
    FAutoCutDecimal: Boolean;         //自动截取小数
    FAppectMinus: Boolean;            //接受负数

    FFormatStr: string;               //文本格式化字串
    FMaxLength: Integer;

    FDecimalPlaces,                     //小数位数
    FIntegerLength: Byte;               //整数长度

    FHideZeroValue: Boolean;            //隐藏零值

    procedure UpdateEditText(Value: Extended);
    procedure UpdateMaxLength;
    procedure UpdateFormatStr;

    functionGetFloatValue: Extended;
    procedure SetFloatValue(const Value: Extended);

    procedure SetDecimalPlaces(const Value: Byte);
    procedure SetIntegerLength(const Value: Byte);

    procedure SetValueType(const Value: TValueType);
    procedure SetShowThousands(const Value: Boolean);
    procedure SetHideZeroValue(const Value: Boolean);
public
    constructor Create(EditControl: TCustomEditEx); reintroduce; virtual;
published
    property ValueType: TValueType read FValueType write SetValueType default vtString;
    property FloatValue: Extended read GetFloatValue write SetFloatValue;

    property ShowThousands: Boolean read FShowThousands write SetShowThousands default False;
    property AutoCutDecimal: Boolean read FAutoCutDecimal write FAutoCutDecimal default False;
    property AppectMinus: Boolean read FAppectMinus write FAppectMinus default False;

    property DecimalPlaces: Byte read FDecimalPlaces write SetDecimalPlaces default 2;
    property IntegerLength: Byte read FIntegerLength write SetIntegerLength default 8;
    property HideZeroValue: Boolean read FHideZeroValue write SetHideZeroValue default False;

    property FormatStr: string read FFormatStr;
    property MaxLength: Integer read FMaxLength;
end;

TCustomEditEx = class(TCustomEdit)
private
    FHintTextFont: TFont;
    FHintText: string;
    FOnPaintHintText: TPaintHintTextEvent;

    FAlignment: TAlignment;
    FValueSetting: TValueSetting;

    function IsTextEmpty: Boolean;
    function IsHintTextEmpty: Boolean;

    procedure SetHintTextFont(const Value: TFont);
    procedure SetHintText(const Value: string);
    procedure SetAlignment(const Value: TAlignment);

    procedure WMSetFocus(var Message: TWMSetFocus); message WM_SETFOCUS;
    procedure WMKillFocus(var Message: TWMSetFocus); message WM_KILLFOCUS;
    procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
    procedure WMGetDlgCode(var Message: TWMGetDlgCode); message WM_GETDLGCODE;
    procedure WMKeyDown(var Message: TWMKeyDown); message WM_KEYDOWN;
    procedure WMPaste(var Message: TMessage); message WM_PASTE;
protected
    FCanvas: TCanvas;
    procedure CreateWnd; override;
    procedure CreateParams(var Params: TCreateParams); override;
    procedure UpdateEditMargins; dynamic;
    procedure WndProc(var Message: TMessage); override;
    procedure KeyPress(var Key: Char); override;

    property HintText: string read FHintText write SetHintText;
    property HintTextFont: TFont read FHintTextFont write SetHintTextFont;
    property Alignment: TAlignment read FAlignment write SetAlignment default taLeftJustify;
    property OnPaintHintText: TPaintHintTextEvent read FOnPaintHintText write FOnPaintHintText;
    property ValueSetting: TValueSetting read FValueSetting write FValueSetting;
public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
end;

type
TEditEx = class(TCustomEditEx)
published
    property HintText;
    property HintTextFont;
    property OnPaintHintText;
    property Alignment;
    property ValueSetting;

    property Align;
    property Anchors;
    property AutoSelect;
    property AutoSize;
    property BevelEdges;
    property BevelInner;
    property BevelKind default bkNone;
    property BevelOuter;
    property BevelWidth;
    property BiDiMode;
    property BorderStyle;
    property CharCase;
    property Color;
    property Constraints;
    property Ctl3D;
    property DragCursor;
    property DragKind;
    property DragMode;
    property Enabled;
    property Font;
    property HideSelection;
    property ImeMode;
    property ImeName;
    property MaxLength;
    property OEMConvert;
    property ParentBiDiMode;
    property ParentColor;
    property ParentCtl3D;
    property ParentFont;
    property ParentShowHint;
    property PasswordChar;
    property PopupMenu;
    property ReadOnly;
    property ShowHint;
    property TabOrder;
    property TabStop;
    property Text;
    property Visible;
    property OnChange;
    property OnClick;
    property OnContextPopup;
    property OnDblClick;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDock;
    property OnEndDrag;
    property OnEnter;
    property OnExit;
    property OnKeyDown;
    property OnKeyPress;
    property OnKeyUp;
    property OnMouseActivate;
    property OnMouseDown;
    property OnMouseEnter;
    property OnMouseLeave;
    property OnMouseMove;
    property OnMouseUp;
    property OnStartDock;
    property OnStartDrag;
end;

   procedure Register;

implementation

procedure Register;
begin
RegisterComponents('hgPack', );
end;

{ TValueSetting }

function StrToValue(S: string; CutComma: Boolean): Extended;
begin
S := Trim(S);
if Length(S) = 0 then
begin
    Result := 0;
    Exit;
end;

if CutComma then
    S := StringReplace(S, ',', '', );
try
    Result := StrToFloat(S);
except
    Result := 0;
end;
end;

constructor TValueSetting.Create(EditControl: TCustomEditEx);
begin
FEditControl := EditControl;
FValueType := vtString;
FShowThousands := False;
FAppectMinus   := False;
FAutoCutDecimal := False;
FDecimalPlaces := 2;
FIntegerLength := 8;
FFormatStr := '0.00';
FHideZeroValue := False;
UpdateMaxLength;
end;

procedure TValueSetting.UpdateEditText(Value: Extended);
begin
if ValueType <> vtFloat then Exit;

if FHideZeroValue and (Value = 0) then
    FEditControl.Text := ''
else
begin
    if FShowThousands then
      FEditControl.Text := FormatFloat(FFormatStr, Value)
    else
      FEditControl.Text := FormatFloat(FFormatStr, Value);
end;
end;

procedure TValueSetting.UpdateFormatStr;
var
I: Integer;
IntegerFormat, DecimalFormat: string;
begin
if FShowThousands then
    IntegerFormat := '#,0'
else
    IntegerFormat := '0';

if FDecimalPlaces > 0 then
begin
    IntegerFormat := IntegerFormat + '.';

    DecimalFormat := '';
    for I := 1 to FDecimalPlaces do
      DecimalFormat := DecimalFormat + '0';
end;
FFormatStr := IntegerFormat + DecimalFormat;
end;

procedure TValueSetting.UpdateMaxLength;
begin
FMaxLength := FIntegerLength;

if FShowThousands then
begin
    FMaxLength := FIntegerLength + FIntegerLength div 3;
    if FIntegerLength mod 3 = 0 then
      Dec(FMaxLength);
end;

if FDecimalPlaces > 0 then
    FMaxLength := FMaxLength + 1 + FDecimalPlaces;
end;

procedure TValueSetting.SetDecimalPlaces(const Value: Byte);
begin
if FDecimalPlaces <> Value then
begin
    FDecimalPlaces := Value;

    UpdateMaxLength;
    UpdateFormatStr;
    UpdateEditText(FloatValue);
end;
end;

procedure TValueSetting.SetIntegerLength(const Value: Byte);
begin
if FIntegerLength <> Value then
begin
    FIntegerLength := Value;
    UpdateMaxLength;
end;
end;

procedure TValueSetting.SetShowThousands(const Value: Boolean);
begin
if FShowThousands <> Value then
begin
    FShowThousands := Value;
    UpdateMaxLength;
    UpdateFormatStr;
    UpdateEditText(FloatValue);
end;
end;

procedure TValueSetting.SetFloatValue(const Value: Extended);
begin
FEditControl.Modified := False;
if FValueType <> vtFloat then
    FEditControl.Text := FloatToStr(Value)
else
    UpdateEditText(Value);
end;

procedure TValueSetting.SetHideZeroValue(const Value: Boolean);
begin
if FHideZeroValue <> Value then
begin
    FHideZeroValue := Value;
    UpdateEditText(FloatValue);
end;
end;

function TValueSetting.GetFloatValue: Extended;
begin
Result := StrToValue(FEditControl.Text, (ValueType = vtFloat) and FShowThousands)
end;

procedure TValueSetting.SetValueType(const Value: TValueType);
var
OldHeight: Integer;
OldType: TValueType;
Style: Longint;
begin
if FValueType <> Value then
begin
    OldHeight := FEditControl.Height;
    OldType := FValueType;
    FValueType := Value;

    if OldType = vtNumberOnly then
    begin
      Style := GetWindowLong(FEditControl.Handle, GWL_STYLE);
      SetWindowLong(FEditControl.Handle, GWL_STYLE, Style and not ES_NUMBER);
      FEditControl.Height := OldHeight;
    end;

    if FValueType = vtNumberOnlythen
    begin
      Style := GetWindowLong(FEditControl.Handle, GWL_STYLE);
      SetWindowLong(FEditControl.Handle, GWL_STYLE, Style or ES_NUMBER);
      FEditControl.Height := OldHeight;
    end
    else if Value = vtFloat then
      UpdateEditText(FloatValue);
end;
end;

{ TEditEx }

constructor TCustomEditEx.Create(AOwner: TComponent);
begin
inherited;
FAlignment := taLeftJustify;
FCanvas := TControlCanvas.Create;
TControlCanvas(FCanvas).Control := Self;

FValueSetting := TValueSetting.Create(Self);

FHintTextFont := TFont.Create;
FHintTextFont.Assign(Font);
end;

destructor TCustomEditEx.Destroy;
begin
FreeAndNil(FHintTextFont);
FreeAndNil(FCanvas);
FreeAndNil(FValueSetting);
inherited;
end;

function TCustomEditEx.IsHintTextEmpty: Boolean;
begin
Result := Length(Trim(HintText)) = 0;
end;

procedure TCustomEditEx.CreateParams(var Params: TCreateParams);
const
Alignments: array of DWORD =
    ((ES_LEFT, ES_RIGHT, ES_CENTER),(ES_RIGHT, ES_LEFT, ES_CENTER));
begin
inherited;
Params.Style := Params.Style or ES_MULTILINE or
    Alignments;
{ if not set ES_MULTILINE style then
    SendMessage(Handle, EM_SETRECT, 0, Longint(@R)) not run }
end;

procedure TCustomEditEx.CreateWnd;
begin
inherited;
UpdateEditMargins;
end;

procedure TCustomEditEx.SetAlignment(const Value: TAlignment);
begin
if FAlignment <> Value then
begin
    FAlignment := Value;
    RecreateWnd;
end;
end;

procedure TCustomEditEx.SetHintText(const Value: string);
begin
FHintText := Value;
if IsTextEmpty and (not IsHintTextEmpty) then
    Invalidate;
end;

procedure TCustomEditEx.SetHintTextFont(const Value: TFont);
begin
FHintTextFont.Assign(Value);
if IsTextEmpty and (not IsHintTextEmpty) then
    Invalidate;
end;

procedure TCustomEditEx.UpdateEditMargins;
var
R: TRect;
H: Integer;
begin
//if HandleAllocated then
R := ClientRect;
Inc(R.Left);
Dec(R.Right);

FCanvas.Font.Assign(Font);

H := FCanvas.TextHeight('|');
H := ((R.Bottom - R.Top) - H) div 2;

InflateRect(R, 0, -H);
SendMessage(Handle, EM_SETRECT, 0, Longint(@R));
Invalidate;
end;

procedure TCustomEditEx.WMGetDlgCode(var Message: TWMGetDlgCode);
begin
inherited;
Message.Result := Message.Result and not DLGC_WANTTAB;
Message.Result := Message.Result and not DLGC_WANTALLKEYS;
end;

procedure TCustomEditEx.WMKillFocus(var Message: TWMSetFocus);
begin
inherited;
Invalidate;
end;

procedure TCustomEditEx.WMSetFocus(var Message: TWMSetFocus);
begin
inherited;
Invalidate;
end;

procedure TCustomEditEx.WndProc(var Message: TMessage);
begin
inherited;
case Message.Msg of
    WM_SIZE:      if not (csLoading in ComponentState) then UpdateEditMargins;
    CM_FONTCHANGED: if not (csLoading in ComponentState) then UpdateEditMargins;
end;
end;

procedure TCustomEditEx.WMPaint(var Message: TWMPaint);
var
EnableAfterPaint: Boolean;
Y: Integer;
begin
inherited;
if (not Focused) and (not IsHintTextEmpty) and IsTextEmpty then
begin
    FCanvas.Font.Assign(FHintTextFont);

    EnableAfterPaint := True;
    if Assigned(FOnPaintHintText) then
      FOnPaintHintText(Self, FCanvas, EnableAfterPaint);

    if EnableAfterPaint then
    begin
      Y := (Self.ClientHeight - FCanvas.TextHeight('|')) div 2;
      FCanvas.Brush.Style := bsClear;
      FCanvas.TextOut(3, Y, FHintText);
    end;
end;
end;

procedure TCustomEditEx.WMPaste(var Message: TMessage);
var
HWND: THandle;
Str: string;
E: Double;
begin
if ValueSetting.ValueType <> vtFloat then
begin
    inherited;
    Exit;
end;

if not IsClipboardFormatAvailable(CF_TEXT) then Exit;
try
    OpenClipBoard(Handle);
    HWND := GetClipboardData(CF_TEXT);
    if HWND = 0 then Exit;
    Str := StrPas(GlobalLock(HWND));
    GlobalUnlock(HWND);
finally
    CloseClipBoard;
end;

try
    E := StrToFloat(Str);
except
    Beep;
    Exit;
end;

if ValueSetting.HideZeroValue and (E = 0) then
    Text := ''
else
begin
    if ValueSetting.ShowThousands then
      Str := FormatFloat(ValueSetting.FormatStr, E)
    else
      Str := FormatFloat(ValueSetting.FormatStr, E);

    if Length(Str) > ValueSetting.MaxLength then
    begin
      Beep;
      Exit;
    end
    else
      Text := Str;
end;
end;

function TCustomEditEx.IsTextEmpty: Boolean;
begin
Result := Length(Trim(Text)) = 0;
end;

procedure TCustomEditEx.WMKeyDown(var Message: TWMKeyDown);
var
strFront, strSel, strBack, strText: string;
SelIndex: Integer;
E: Extended;
begin
if not ((ValueSetting.ValueType = vtFloat) and
    (Message.CharCode = VK_DELETE) and (Message.Unused = 0)) then
begin
    inherited;
    Exit;
end;

if ReadOnly then
begin
    inherited;
    Exit;
end;

// 拦截 delete 键
strFront:= Copy(Text, 0, SelStart);
strSel:= Copy(Text, SelStart + 1, SelLength);
strBack := Copy(Text, SelStart + SelLength + 1, MAXINT);
SelIndex := Length(Text) - SelStart - SelLength;

if SelLength > 0 then
    strText := strFront + strBack
else
begin
    strText := strFront + Copy(strBack, 2, MAXINT);
    Dec(SelIndex);
end;

E := StrToValue(strText, ValueSetting.ShowThousands);

if ValueSetting.ShowThousands then
    Text := FormatFloat(ValueSetting.FormatStr, E)
else
    Text := FormatFloat(ValueSetting.FormatStr, E);

SelStart := Length(Text) - SelIndex;
Modified := True;
Message.Result := 1;
end;

procedure TCustomEditEx.KeyPress(var Key: Char);
const
CTRL_A = #1;
CTRL_C = #3;
CTRL_V = #22;
CTRL_X = #24;
CTRL_Z = #26;
var
strFront, strSel, strBack, strText: string;
Index, SelIndex: Integer;
E: Extended;
InputMinus: Boolean;
SetKeys: set of Char;
begin
inherited;
if (ValueSetting.ValueType <> vtFloat) or
    (Key in ) then Exit
else
begin
    if ReadOnly then
    begin
      Key := #0;
      Beep;
      Exit;
    end;
   
    SetKeys := ['-', '.', #8, '0'..'9'];
    if not ValueSetting.AppectMinus then
      Exclude(SetKeys, '-');
    if ValueSetting.DecimalPlaces = 0 then
      Exclude(SetKeys, '.');

    if not (Key in SetKeys) then
    begin
      Key := #0;
      Beep;
      Exit;
    end;
end;

InputMinus := False;   
SelIndex := Length(Text) - SelStart - SelLength;

strFront:= Copy(Text, 0, SelStart);
strSel:= Copy(Text, SelStart + 1, SelLength);
strBack := Copy(Text, SelStart + SelLength + 1, MAXINT);
if Key = '-' then
begin
    Key := #0;
    if SelStart = 0 then
    begin
      strText :='-' + strBack;
      InputMinus := True;
    end
    else
    begin
      Beep;
      Exit;
    end;
end
else if Key = '.' then
begin
    Key := #0;
    if Pos('.', strFront) = 0 then
    begin
      Index := Pos('.', strBack);
      if Index = 0 then
      strText := strFront + '.' + strBack
      else
      begin
      if ValueSetting.AutoCutDecimal then
      begin
          strText := strFront + '.' + Copy(strBack, Index + 1, MAXINT);
          Dec(SelIndex, Index);
      end
      else
      begin
          Beep;
          Exit;
      end;
      end;
    end
    else
    begin
      Beep;
      Exit;
    end;
end
else if Key = #8 then
begin
    Key := #0;
    if SelLength > 0 then
      strText := strFront + strBack
    else
      strText := Copy(strFront, 0, Length(strFront) - 1) + strBack;
end
else if Key in ['0'..'9'] then
begin
    if SelLength <> 0 then
      strText := strFront + Key + strBack
    else
    begin
      strText := strFront + Key + strBack;

      if Length(strText) > ValueSetting.MaxLength then
      begin
      Index := Pos('.', strFront);
      if Index > 0 then
      begin
          strText := #0;
          Text := strText;
          Modified := True;
          SelStart := Length(Text) - SelIndex;
          Exit;
      end;

      Beep;
      Key := #0;
      Exit;
      end;
    end;
    Key := #0;
end;

E := StrToValue(strText, ValueSetting.ShowThousands);

strText := FormatFloat(ValueSetting.FormatStr, E);

if (E = 0) and InputMinus then
    strText := '-' + strText;
Text := strText;
SelStart := Length(Text) - SelIndex;
Modified := True;
end;


end.

一帆风 发表于 2009-11-1 22:30:56

好长！辛苦了

MOV 发表于 2009-11-2 00:01:40

虽然看不懂还是顶上了

HDd1145 发表于 2009-11-2 00:39:52

yayazhi 发表于 2009-11-2 07:55:09

是关于字符和数据处理的吧:loveliness:

孤漂江湖狼 发表于 2009-11-2 09:22:37

不懂Delphi，但还是要支持

liu3062315 发表于 2009-11-2 14:15:46

没有看明白,唉水平太差了

ampeter 发表于 2017-6-11 13:13:09

好东西~~~~~~~~~~~~~~~~~~

chenwenyongwy 发表于 2021-1-10 02:03:34

都不简介怎么使用吗

七色九天 发表于 2021-1-10 04:50:19

看看控件怎么写的啊

查看完整版本: 初来乍到，贡献一控件吧。前两天写的。