Delphi控件制作技巧

　　{$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,sdDate);
　　  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;
　　    function  GetAsDate(): 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);
　　    }
　　    procedure SetOnClick(const Value:TNotifyEvent);
　　    procedure SetOnKeyPress(const Value:TKeyPressEvent);
　　    procedure SetOnEnter(const Value:TNotifyEvent);
　　    procedure SetOnExit(const Value:TNotifyEvent);
　　  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 AsDate: string read GetAsDate ;
　　    property AsStr: string read GetAsText write SetAsText;
　　    property OnClick: TNotifyEvent read FOnClick write SetOnClick;
　　    property OnKeyPress: TKeyPressEvent read FOnKeyPress write SetOnKeyPress;
　　    property OnEnter: TNotifyEvent read FOnEnter write SetOnEnter;
　　    property OnExit: TNotifyEvent read FOnExit write SetOnExit;
　　    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;
　　      SdDate:FEdit.InputStyle:=IsDate;
　　      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.GetAsDate(): string;
　　var
　　  TempDate:TDateTime;
　　begin
　　  if TryStrToDate(FMcText,TempDate) then Result:=FormatDateTime('YYYY-MM-DD',TempDate)
　　  else Result:='';
　　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);
　　        SdDate:DrawText(Handle, PChar(AsDate), StrLen(PChar(AsDate)), 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<>''))
　　         or (FDataType=SdDate) 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 TSelectDa.SetOnClick(const Value:TNotifyEvent);
　　begin
　　  if @FOnClick<>@Value then
　　  begin
　　    FOnClick:=Value;
　　    FButton.OnClick:=FOnClick;
　　  end;
　　end;

　　procedure TSelectDa.SetOnKeyPress(const Value:TKeyPressEvent);
　　begin
　　  if @FOnKeyPress<>@Value then
　　  begin
　　    FOnKeyPress:=Value;
　　    FEdit.OnKeyPress:=FOnKeyPress;
　　  end;
　　end;

　　procedure TSelectDa.SetOnEnter(const Value:TNotifyEvent);
　　begin
　　  if @FOnEnter<>@Value then
　　  begin
　　    FOnEnter:=Value;
　　    FEdit.OnEnter:=FOnEnter;
　　  end;
　　end;

　　procedure TSelectDa.SetOnExit(const Value:TNotifyEvent);
　　begin
　　  if @FOnExit<>@Value then
　　  begin
　　    FOnExit:=Value;
　　    FEdit.OnExit:=FOnExit;
　　  end;
　　end;

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

　　end.