Delphi控件制作技巧[二]

2019-11-18 18:03:06

字体：大中小

来源：转载

供稿：网友

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,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.

上一篇：变速齿轮Delphi实现

下一篇：Delphi关于线程的消息处理