Delphi控件制作技巧[一]

核心提示： unit USWLMSelectDa;{$S-,W-,R-} {$C PRELOAD}interfaceuses Windows,Messages,SysUtils, Types, Classes, Graphics, Controls,StdCtrls,Forms, StrUtils,Math,ADODB,TF

 

unit USWLMSelectDa;

{$S-,W-,R-}　　　　　　　　　　　　　　　　　　　　　　
{$C PRELOAD}

interface

uses
  Windows,Messages,SysUtils, Types, Classes, Graphics, Controls,StdCtrls,Forms,
  StrUtils,Math,ADODB,TFlatButtonUnit,USWLMStyleEdit;

type
  TEditDataType = (sdString, sdInteger,sdFloat,sdMoney);
  TVAlignment = (tvaTopJustify, tvaCenter, tvaBottomJustify);
  TDataStyle = (dsBm, dsZj, dsMc);
type
  TSelectDa = class(TCustomControl)
  private
　  FPen: TPen;
　  FBrush:TBrush;
　  FFont:TFont;
　  FCaption:string;
　  FBmText:string;
　  FZjText:string;
　  FMcText:string;
　  FDataType: TEditDataType;
　  FPrecision: Integer;
　  FReadOnly:Boolean;
　  FEditFont:TFont;
　  FHAlignment : TAlignment;
　  FVAlignment : TVAlignment;
　  FEdit:TStyleEdit;
　  FButton:TFlatButton;
　  FTitleName:string;
　  FTableName:string;
　  FDataStyle:TDataStyle;
　  FBmField:string;
　  FZjField:string;
　  FMcField:string;
　  FOnClick: TNotifyEvent;
　  FOnEnter: TNotifyEvent;
　  FOnExit: TNotifyEvent;
　  FOnKeyPress: TKeyPressEvent;
　  procedure SetPen(const Value:TPen);
　  procedure SetBrush(const Value:TBrush);
　  procedure SetFont(const Value:TFont);
　  procedure SetCaption(const Value:string);
　  procedure SetBmText(const Value:string);
　  procedure SetZjText(const Value:string);
　  procedure SetMcText(const Value:string);
　  procedure SetDataType(const Value: TEditDataType);
　  procedure SetPrecision(const Value: Integer);
　  procedure SetReadOnly(const Value:Boolean);
　  procedure SetEditFont(const Value:TFont);
　  procedure SetHAlignment(const Value:TAlignment);
　  procedure SetVAlignment(const Value:TVAlignment);
　  procedure SetTitleName(const Value:string);
　  procedure SetTableName(const Value:string);
　  procedure SetDataStyle(const Value:TDataStyle);
　  procedure SetBmField(const Value:string);
　  procedure SetZjField(const Value:string);
　  procedure SetMcField(const Value:string);
　  function  GetAsFloat(): string;
　  function  GetAsMoney(): string;
　  function  GetAsInteger(): string;
　  function  GetAsText(): string;
　  procedure SetAsFloat(const Value: string);
　  procedure SetAsMoney(const Value: string);
　  procedure SetAsInteger(const Value: string);
　  procedure SetAsText(const Value: string);
　  procedure StyleChanged(Sender: TObject);
　  procedure SetBackColor(const Value : TColor);
　  procedure SetColorOnEnter(const Value : TColor);
　  procedure DoClick(Sender: TObject);
　  procedure DoEnter(Sender: TObject);
　  procedure DoExit(Sender: TObject);
　  procedure DoKeyPress(Sender: TObject; var Key: Char);
  protected
　  procedure Paint; override;
  public
　  constructor Create(AOwner: TComponent); override;
　  destructor  Destroy; override;
  published
　  property Pen: TPen read FPen write SetPen;
　  property Brush: TBrush read FBrush write SetBrush;
　  property Font: TFont read FFont write SetFont;
　  property Caption:string read FCaption write SetCaption;
　  property Bm:string read FBmText write SetBmText ;
　  property Zjf:string read FZjText write SetZjText ;
　  property Mc:string read FMcText write SetMcText ;
　  property Text:string read FMcText write SetMcText;
　  property DataType: TEditDataType read FDataType write SetDataType default SdString;
　  property Precision: Integer read Fprecision write SetPrecision default 2;
　  property ReadOnly: Boolean read FReadOnly write SetReadOnly default False;
　  property EditFont: TFont read FEditFont write SetEditFont;
　  property HAlignment:TAlignment read FHAlignment write SetHAlignment default taLeftJustify;
　  property VAlignment:TVAlignment read FVAlignment write SetVAlignment default tvaBottomJustify;
　  property TitleName:string read FTitleName write SetTitleName ;
　  property TableName:string read FTableName write SetTableName ;
　  property DataStyle:TDataStyle read FDataStyle write SetDataStyle default dsBm;
　  property BmField:string read FBmField write SetBmField ;
　  property ZjField:string read FZjField write SetZjField ;
　  property McField:string read FMcField write SetMcField ;
　  property AsFloat:string read GetAsFloat {write SetAsFloat};
　  property AsMoney:string read GetAsMoney {write SetAsMoney};
　  property AsInt: string read GetAsInteger {write SetAsInteger};
　  property AsStr: string read GetAsText write SetAsText;
　  property OnClick: TNotifyEvent read FOnClick write FOnClick;
　  property OnKeyPress: TKeyPressEvent read FOnKeyPress write FOnKeyPress;
　  property OnEnter: TNotifyEvent read FOnEnter write FOnEnter;
　  property OnExit: TNotifyEvent read FOnExit write FOnExit;
　  property BackColor : TColor write SetBackColor;
　  property ColorOnEnter : TColor write SetColorOnEnter;
　  property AlignDisabled;
　  property VisibleDockClientCount;
　  property ControlCount;
　  property ParentWindow;
　  property Showing;
　  property TabOrder;
　  property TabStop;
  end;

procedure Register;

implementation

uses Consts;

procedure TSelectDa.SetPen(const Value: TPen);
begin
  FPen.Assign(Value);
  Invalidate;
end;

procedure TSelectDa.SetBrush(const Value:TBrush);
begin
  FBrush.Assign(Value);
  Invalidate;
end;

procedure TSelectDa.SetFont(const Value:TFont);
begin
  FFont.Assign(Value);
  Invalidate;
end;

procedure TSelectDa.SetCaption(const Value:string);
begin
  if FCaption <> Value then
  begin
　  FCaption:=Value;
　  Invalidate;
  end;
end;

procedure TSelectDa.SetBmText(const Value:string);
begin
  if FBmText <> Value then
  begin
　  FBmText:=Value;
　  Invalidate;
  end;
end;

procedure TSelectDa.SetZjText(const Value:string);
begin
  if FZjText <> Value then
  begin
　  FZjText:=Value;
  end;
end;

procedure TSelectDa.SetMcText(const Value:string);
begin
  if FMcText <> Value then
  begin
　  FMcText:=Value;
　  Invalidate;
  end;
end;

procedure TSelectDa.SetReadOnly(const Value:Boolean);
begin
  if FReadOnly<>Value then
  begin
　  FReadOnly:=Value;
　  Invalidate;
  end;
end;

procedure TSelectDa.SetEditFont(const Value:TFont);
begin
  FEditFont.Assign(Value);
  Invalidate;
end;

procedure TSelectDa.SetPrecision(const Value: Integer);
begin
  if Fprecision<>Value then
  begin
　  case Value of
　  1..6:FPrecision:=Value;
　  else FPrecision:=2;
　  end;
　  Invalidate;
  end;
end;

procedure TSelectDa.SetDataType(const Value: TEditDataType);
begin
  if FDataType <> Value then
  begin
　  FDataType:=Value;
　  case FDataType of
　　  SdString:FEdit.InputStyle:=IsString;
　　  SdInteger:FEdit.InputStyle:=IsInteger;
　　  SdFloat:FEdit.InputStyle:=IsFloat;
　　  SdMoney:FEdit.InputStyle:=IsMoney;
　　  else FEdit.InputStyle:=IsString;
　  end;
　  Invalidate;
  end;
end;

procedure TSelectDa.SetHAlignment(const Value:TAlignment);
begin
  if FHAlignment <> Value then
  begin
　　  FHAlignment:=Value;
　　  Invalidate;
  end;
end;

procedure TSelectDa.SetVAlignment(const Value:TVAlignment);
begin
  if FVAlignment <> Value then
  begin
　　  FVAlignment:=Value;
　　  Invalidate;
  end;
end;

procedure TSelectDa.SetTitleName(const Value:string);
begin
  if FTitleName<>Value then FTitleName:=Value;
end;

procedure TSelectDa.SetTableName(const Value:string);
begin
  if FTableName<>Value then
  begin
　  FTableName:=Value;
　  Invalidate;
  end;
end;

procedure TSelectDa.SetDataStyle(const Value:TDataStyle);
begin
  if FDataStyle<>Value then FDataStyle:=Value;
end;

procedure TSelectDa.SetBmField(const Value:string);
begin
  if FBmField<>Value then
  begin
　　  FBmField:=Value;
　　  Invalidate;
  end;
end;

procedure TSelectDa.SetZjField(const Value:string);
begin
  if FZjField<>Value then  FZjField:=Value;
end;

procedure TSelectDa.SetMcField(const Value:string);
begin
  if FMcField<>Value then
  begin
　　  FMcField:=Value;
　　  Invalidate;
  end;
end;

function  TSelectDa.GetAsFloat: string;
  function StrToDouble(S:string):Double;
  begin
　  if not trystrToFloat(s,Result) then Result:=0;
  end;
begin
  case FPrecision of
  1..6:  Result:=FormatFloat('###0.'+DupeString('0',FPrecision),StrToDouble(FMcText));
  else  Result:=FormatFloat('###0.00',StrToDouble(FMcText));
  end;
end;

function  TSelectDa.GetAsMoney: string;
  function StrToDouble(S:string):Double;
  begin
　  if not trystrToFloat(s,Result) then Result:=0;
  end;
begin
  Result:=FormatFloat('###0.00',StrToDouble(FMcText));
end;

function  TSelectDa.GetAsInteger: string;
  Function StrToInteger(S:string):integer;
  begin
　  if not trystrToInt(s,Result) then Result:=0;
  end;
begin
  Result:=IntToStr(StrToInteger(FMcText));
end;

function  TSelectDa.GetAsText: string;
begin
  Result:=FMcText;
end;

procedure TSelectDa.SetAsFloat(const Value: string);
  function StrToDouble(S:string):Double;
  begin
　  if not trystrToFloat(s,Result) then Result:=0;
  end;
var
  f:Double;
begin
  f:=StrToDouble(Value);
  case FPrecision of
  1..6:
  begin
　  f:=RoundTo(f,-FPrecision);
　  SetMcText(FormatFloat('###0.'+DupeString('0',FPrecision),f));
  end
  else
  begin
　  f:=RoundTo(f,-2);
　  SetMcText(FormatFloat('###0.00',f));
  end;
  end;
end;

procedure TSelectDa.SetAsMoney(const Value: string);
  function StrToDouble(S:string):Double;
  begin
　  if not trystrToFloat(s,Result) then Result:=0;
  end;
var
  f:Double;
begin
  f:=StrToDouble(Value);
  f:=RoundTo(f,-2);
  SetMcText(FormatFloat('###0.00',f));
end;

procedure TSelectDa.SetAsInteger(const Value: string);
  Function StrToInteger(S:string):integer;
  begin
　  if not trystrToInt(s,Result) then Result:=0;
  end;
var
  i:Integer;
begin
  i:=StrToInteger(Value);
  SetMcText(IntToStr(i));
end;

procedure TSelectDa.SetAsText(const Value: string);
begin
  SetMcText(Value);
end;

procedure TSelectDa.StyleChanged(Sender: TObject);
begin
  Invalidate;
end;

procedure TSelectDa.SetBackColor(const Value : TColor);
begin
  FEdit.BackColor:=Value;
end;

procedure TSelectDa.SetColorOnEnter(const Value : TColor);
begin
  FEdit.ColorOnEnter:=Value;
end;

constructor TSelectDa.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  Width:=188;
  Height:=20;
  FCaption:='未命名';
  FBmText:='';
  FZjText:='';
  FMcText:='';
  FReadOnly:=False;
  FHAlignment:=taLeftJustify;
  FVAlignment:=tvaBottomJustify;
  FDataType:=SdString;
  FPrecision:=2;
  FTitleName:='';
  FTableName:='';
  FDataStyle:=dsBm;
  FBmField:='';
  FZjField:='';
  FMcField:='';
  FPen := TPen.Create;
  FPen.OnChange:=StyleChanged;
  FBrush := TBrush.Create;
  FBrush.OnChange:=StyleChanged;
  FFont := TFont.Create;
  FFont.OnChange:=StyleChanged;
  FFont.Charset:=GB2312_CHARSET;
  FFont.Name:='宋体';
  FFont.Size:=9;
  FEditFont := TFont.Create;
  FEditFont.OnChange:=StyleChanged;
  FEditFont.Charset:=GB2312_CHARSET;
  FEditFont.Name:='宋体';
  FEditFont.Size:=9;
  FEdit:=TStyleEdit.Create(Self);
  FEdit.Parent:=Self;
  FEdit.BorderStyle:=bsNone;
  FEdit.InputStyle:=isString;
  FEdit.OnKeyPress:=DoKeyPress;
  FEdit.OnEnter:=DoEnter;
  FEdit.OnExit:=DoExit;
  FButton:=TFlatButton.Create(Self);
  FButton.Parent:=Self;
  FButton.Font:=FFont;
  FButton.ColorBorder:=FBrush.Color;
  FButton.Color:=FBrush.Color;
  FButton.ColorDown:=FBrush.Color;
  FButton.ColorShadow:=FBrush.Color;
  FButton.ColorFocused:=FBrush.Color;
  FButton.Width:=19;
  FButton.Caption:='…';
  FButton.OnClick:=DoClick;
end;

procedure TSelectDa.Paint;
var
  aText:Pchar;
  aRect:TRect;
  Flag:DWord;
begin
  with Canvas do
  begin
　  Font:=FFont;
　  Pen:=FPen;
　  Brush:=FBrush;
　  FillRect(ClientRect);
　  if FBmText<>'' then aText:=Pchar(FCaption+'['+FBmText+']') else aText:=Pchar(FCaption);
　  aRect:=Rect(ClientRect.Left+FPen.Width, ClientRect.Top+FPen.Width, ClientRect.Right-FPen.Width, ClientRect.Bottom-FPen.Width);
　  DrawText(Handle, aText, StrLen(aText), aRect, (DT_SINGLELINE or DT_VCENTER) or DT_LEFT);
　  Inc(aRect.Left,TextWidth(aText));
　  Dec(aRect.Right,FButton.Width);
　  MoveTo(aRect.Left,aRect.Bottom);
　  LineTo(aRect.Right,aRect.Bottom);
　  Inc(aRect.Left,FPen.Width);
　  if FReadOnly then
　  begin
　　  FEdit.Visible:=False;
　　  FButton.Visible:=False;
　　  Flag:=DT_SINGLELINE;
　　  case FHAlignment of
　　　  taLeftJustify:Flag:=Flag or DT_LEFT;
　　　  taRightJustify:Flag:=Flag or DT_RIGHT;
　　　  taCenter:Flag:=Flag or DT_CENTER;
　　　  else Flag:=Flag or DT_LEFT;
　　  end;
　　  case FVAlignment of
　　　  tvaTopJustify:Flag:=Flag or DT_TOP;
　　　  tvaCenter:Flag:=Flag or DT_VCENTER;
　　　  tvaBottomJustify:Flag:=Flag or DT_BOTTOM;
　　　  else Flag:=Flag or DT_BOTTOM;
　　  end;
　　  Font:=FEditFont;
　　  case FDataType of
　　　  SdString:DrawText(Handle, PChar(AsStr),  StrLen(PChar(AsStr)), aRect, Flag);
　　　  SdInteger:DrawText(Handle, PChar(AsInt), StrLen(PChar(AsInt)), aRect, Flag);
　　　  SdFloat:DrawText(Handle, PChar(AsFloat), StrLen(PChar(AsFloat)), aRect, Flag);
　　　  SdMoney:DrawText(Handle, PChar(AsMoney), StrLen(PChar(AsMoney)), aRect, Flag);
　　  end;
　  end
　  else
　  begin
　　  FEdit.Alignment:=FHAlignment;
　　  FEdit.Font:=FEditFont;
　　  FEdit.Text:=FMcText;
　　  FEdit.Width:=aRect.Right-aRect.Left;
　　  FEdit.Height:=Min(Max(TextHeight(FMcText),TextHeight(FCaption)),aRect.Bottom-aRect.Top);
　　  FEdit.Left:=aRect.Left;
　　  case FVAlignment of
　　　  tvaTopJustify:FEdit.Top:=aRect.Top;
　　　  tvaCenter:FEdit.Top:=aRect.Top+(aRect.Bottom-aRect.Top-FEdit.Height)div 2;
　　　  tvaBottomJustify:FEdit.Top:=aRect.Top+(aRect.Bottom-aRect.Top-FEdit.Height);
　　　  else FEdit.Top:=aRect.Top;
　　  end;
　　  FButton.Left:=aRect.Right;
　　  FButton.Top:=aRect.Top;
　　  FButton.Height:=aRect.Bottom-aRect.Top;
　　  if (FDataType=SdString) and (FBmField<>'') and (FMcField<>'') and (FTableName<>'') then FButton.Visible:=True
　　  else FButton.Visible:=False;
　  end;
  end;
end;

destructor TSelectDa.Destroy;
begin
  FPen.Free;
  FBrush.Free;
  FFont.Free;
  FEditFont.Free;
  if Assigned(FEdit) then FreeAndNil(FEdit);
  if Assigned(FButton) then FreeAndNil(FButton);
  inherited Destroy;
end;

procedure TSelectDa.DoClick(Sender: TObject);
begin
  if Assigned(FOnClick) then FOnClick(Self);
end;

procedure TSelectDa.DoEnter(Sender: TObject);
begin
  if Assigned(FOnEnter) then FOnEnter(Self);
end;

procedure TSelectDa.DoExit(Sender: TObject);
begin
  if Assigned(FOnExit) then FOnExit(Self);
end;

procedure TSelectDa.DoKeyPress(Sender: TObject; var Key: Char);
begin
  if Assigned(FOnKeyPress) then FOnKeyPress(Self,Key);
end;

procedure Register;
begin
  RegisterComponents('swlmsoft', [TSelectDa]);
end;

end.