Delphi+XE2圆角矩形Edit代码.docx

1、Delphi+XE2圆角矩形Edit代码Delphi XE2圆角矩形Edit代码测测在XE2下可用unit uAkanShapeEdit;interfaceusesWinapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, Vcl.ExtCtrls,math,uJohnPNGButton;Type TBoundShape TBoundShape = class(

2、TGraphicControl)privateFPen: TPen;FBrush: TBrush;FShape: TShapeType;FFocusControl: TWinControl;FSpacing: Integer;procedure SetBrush(Value: TBrush);procedure SetPen(Value: TPen);procedure SetShape(Value: TShapeType);function GetHeight: Integer;function GetLeft: Integer;function GetTop: Integer;functi

3、on GetWidth: Integer;procedure SetHeight(const Value: Integer);procedure SetWidth(const Value: Integer);procedure SetFocusControl(const Value: TWinControl);protectedprocedure Paint; override;/add*procedure AdjustBounds; dynamic;property FocusControl: TWinControl read FFocusControl write SetFocusCont

4、rol;publicconstructor Create(AOwner: TComponent); override;destructor Destroy; override;publishedprocedure StyleChanged(Sender: TObject);property Align;property Anchors;property Brush: TBrush read FBrush write SetBrush;property DragCursor;property DragKind;property DragMode;property Enabled;property

5、 Constraints;property ParentShowHint;property Pen: TPen read FPen write SetPen;property Shape: TShapeType read FShape write SetShape default stRectangle;property ShowHint;property Touch;property Visible;property OnContextPopup;property OnDragDrop;property OnDragOver;property OnEndDock;property OnEnd

6、Drag;property OnMouseActivate;property OnMouseDown;property OnMouseEnter;property OnMouseLeave;property OnMouseMove;property OnMouseUp;property OnGesture;property OnStartDock;property OnStartDrag;/Add *property Left: Integer read GetLeft;property Top: Integer read GetTop;property Height: Integer rea

7、d GetHeight write SetHeight;property Width: Integer read GetWidth write SetWidth;end; TCustomLabeledEdit TCustomShapedEdit = class(TCustomEdit)privateFBoundShape: TBoundShape;FShapeSpacing: Integer;FFocusControl: TWinControl;FFocusEnabled: boolean;FPromptText: string;procedure SetShapePosition;proce

8、dure SetShapeSpacing(const Value: Integer);procedure SetFocusControl(const Value: TWinControl);procedure SetPromptText(const Value: string);protectedprocedure SetParent(AParent: TWinControl); override;procedure Notification(AComponent: TComponent; Operation: TOperation); override;procedure SetName(c

9、onst Value: TComponentName); override;procedure CMVisiblechanged(var Message: TMessage);message CM_VISIBLECHANGED;procedure CMEnabledchanged(var Message: TMessage);message CM_ENABLEDCHANGED;procedure CMBidimodechanged(var Message: TMessage);message CM_BIDIMODECHANGED;procedure CMEnter(var Message: T

10、CMEnter); message CM_ENTER;procedure CMExit(var Message: TCMExit); message CM_EXIT;public Public declarations constructor Create(AOwner: TComponent); override;procedure SetBounds(ALeft: Integer; ATop: Integer; AWidth: Integer; AHeight: Integer); override;procedure SetupInternalShape;property EditSha

11、pe: TBoundShape read FBoundShape;property ShapeSpacing: Integer read FShapeSpacing write SetShapeSpacing default 3;function CanFocus: Boolean;override;/add *property PromptText :string read FPromptText write SetPromptText;end; TShapedEdit TShapedEdit = class(TCustomShapedEdit)publishedproperty Align

12、ment;property Anchors;property AutoSelect;property AutoSize;property BevelEdges;property BevelInner;property BevelKind;property BevelOuter;property BiDiMode;property BorderStyle;property CharCase;property Color;property Constraints;property Ctl3D;property DoubleBuffered;property DragCursor;property

13、DragKind;property DragMode;property EditShape;property Enabled;property Font;property HideSelection;property ImeMode;property ImeName;property ShapeSpacing;property MaxLength;property OEMConvert;property NumbersOnly;property ParentBiDiMode;property ParentColor;property ParentCtl3D;property ParentDou

14、bleBuffered;property ParentFont;property ParentShowHint;property PasswordChar;property PopupMenu;property ReadOnly;property ShowHint;property TabOrder;property TabStop;property Text;property TextHint;property Touch;property Visible;property OnChange;property OnClick;property OnContextPopup;property

15、OnDblClick;property OnDragDrop;property OnDragOver;property OnEndDock;property OnEndDrag;property OnEnter;property OnExit;property OnGesture;property OnKeyDown;property OnKeyPress;property OnKeyUp;property OnMouseActivate;property OnMouseDown;property OnMouseEnter;property OnMouseLeave;property OnMo

16、useMove;property OnMouseUp;property OnStartDock;property OnStartDrag;/property PromptText;end;procedure Register;implementationprocedure Register;beginRegisterComponents(EvoJohn, TShapedEdit);end; TBoundShape procedure TBoundShape.AdjustBounds;constWordWraps: arrayBoolean of Word = (0, DT_WORDBREAK)

17、;varDC: HDC;X: Integer;Rect: TRect;/AAlignment: TAlignment;beginif not (csReading in ComponentState) thenbeginRect := ClientRect;DC := GetDC(0);tryCanvas.Handle := DC;/DoDrawText(Rect, (DT_EXPANDTABS or DT_CALCRECT) or WordWrapsFWordWrap);Canvas.Handle := 0;finallyReleaseDC(0, DC);end;X := Left;AAli

18、gnment := FAlignment;if UseRightToLeftAlignment thenChangeBiDiModeAlignment(AAlignment);if AAlignment = taRightJustify thenInc(X, Width - Rect.Right); SetBounds(X, Top, Rect.Right, Rect.Bottom);end;/if Owner is TCustomShapedEdit thenwith Owner as TCustomShapedEdit doSetShapePosition;end;constructor

19、TBoundShape.Create(AOwner: TComponent);begininherited Create(AOwner);ControlStyle := ControlStyle + csReplicatable;Width := 65;Height := 65;FPen := TPen.Create;FPen.OnChange := StyleChanged;FBrush := TBrush.Create;FBrush.OnChange := StyleChanged;/Add *Name := SubLabel; do not localize SetSubComponen

20、t(True);if Assigned(AOwner) thenCaption := AOwner.Name;end;destructor TBoundShape.Destroy;beginFPen.Free;FBrush.Free;inherited Destroy;end;function TBoundShape.GetHeight: Integer;beginResult := inherited Height;end;function TBoundShape.GetLeft: Integer;beginResult := inherited Left;end;function TBou

21、ndShape.GetTop: Integer;beginResult := inherited Top;end;function TBoundShape.GetWidth: Integer;beginResult := inherited Width;end;procedure TBoundShape.Paint;varX, Y, W, H, S: Integer;R : Trect;i:integer;z,dz:double;beginwith Canvas dobeginPen := FPen;Brush := FBrush;X := Pen.Width div 2;Y := X;W :

22、= Width - Pen.Width + 1;H := Height - Pen.Width + 1;if Pen.Width = 0 thenbeginDec(W);Dec(H);end;if W H then S := W else S := H;if FShape in stSquare, stRoundSquare, stCircle thenbeginInc(X, (W - S) div 2);Inc(Y, (H - S) div 2);W := S;H := S;end;case FShape ofstRectangle, stSquare:Rectangle(X, Y, X +

23、 W, Y + H);stRoundRect, stRoundSquare:RoundRect(X, Y, X + W, Y + H, S div 4, S div 4);stCircle, stEllipse:Ellipse(X, Y, X + W, Y + H);end;end; /if Owner is TCustomShapedEdit thenwith (Owner as TCustomShapedEdit),Canvas dobeginPen := FPen;Brush := FBrush;X := Pen.Width div 2;Y := X;W := Width - Pen.W

24、idth + 1 + Fspacing * 2;H := Height - Pen.Width + 1 + Fspacing * 2;if Pen.Width = 0 thenbeginDec(W);Dec(H);end;if W H then S := W else S := H;RoundRect(X, Y, X + W, Y + H, S div 4, S div 4); /测测色dz := Fspacing/20;z:=0;for I := 20 downto 0 dobeginBrush.Color :=clwhite-i;Pen.Color := clwhite-i;RoundRe

25、ct(X + round(z+dz), Y + round(z+dz), X + W- round(z+dz), Y + H - round(z+dz) , S div 4, S div 4);z:= z+dz;end; SetShapePosition;end;r := Rect(0,0,self.Width,self.Height);Canvas.Brush.Color := clblack;Canvas.Brush.Style := bsSolid;canvas.FillRect(r); end;procedure TBoundShape.SetBrush(Value: TBrush);

26、beginFBrush.Assign(Value);end;procedure TBoundShape.SetFocusControl(const Value: TWinControl);beginFFocusControl := Value;end;procedure TBoundShape.SetHeight(const Value: Integer);beginSetBounds(Left, Top, Width, Value);end;procedure TBoundShape.SetPen(Value: TPen);beginFPen.Assign(Value);end;proced

27、ure TBoundShape.SetShape(Value: TShapeType);beginif FShape Value thenbeginFShape := Value;Invalidate;end;end;procedure TBoundShape.SetWidth(const Value: Integer);beginSetBounds(Left, Top, Value, Height);end;procedure TBoundShape.StyleChanged(Sender: TObject);beginInvalidate;end; TCustomShapedEdit fu

28、nction TCustomShapedEdit.CanFocus: Boolean;beginresult := false;end;procedure TCustomShapedEdit.CMBidimodechanged(var Message: TMessage);begininherited;if FBoundShape nil thenFBoundShape.BiDiMode := BiDiMode;end;procedure TCustomShapedEdit.CMEnabledchanged(var Message: TMessage);varcolor : Tcolor;be

29、ginColor := self.Font.Color;inherited;if FBoundShape nil thenFBoundShape.Enabled := Enabled;self.Font.Color := Color;end;procedure TCustomShapedEdit.CMEnter(var Message: TCMEnter);varForm: TCustomForm;begininherited;if ReadOnly thenbeginForm := GetParentForm(Self);if Form nil then Form.DefocusContro

30、l(Self, false);end elsebeginif Text = PromptText thenbeginText:=;endelsebeginend;end;end;procedure TCustomShapedEdit.CMExit(var Message: TCMExit);begininherited;if Text thenbeginend elsebeginText := PromptText;end;end;procedure TCustomShapedEdit.SetPromptText(const Value: string);beginFPromptText := Value;Text := Value;end;procedure TCustomShapedEdit.CMVisiblechanged(var Message: TMessage);begininherited;