Whenever I use the control of the Delphi, I feel less, the shape is good, the color is good, change
The way is also good, and it is divided with the standards you need for your own project.
The following controls are found to be available! ! !
The following is its source code:
UNIT DSFANCYBUTTON;
Interface
Uses Sysutils, Windows, Messages, Classes, Graphics, Controls, Forms
type TTextStyle = (txNone, txLowered, txRaised, txShadowed); TShape = (shCapsule, shOval, shRectangle, shRoundRect); TDsFancyButton = class (TGraphicControl) private FButtonColor: TColor; FIsDown: Boolean; FFrameColor: TColor; FFrameWidth: Integer; FCornerRadius: Integer; FRGN, MRGN: HRGN; FSHAPE: TSHAPE; FTEXTSTYLOR: TCOLOR; FTEXTSTYLE: TTEXTSTYLE
procedure SetButtonColor (Value: TColor); procedure CMEnabledChanged (var message: TMessage); message CM_ENABLEDCHANGED; procedure CMTextChanged (var message: TMessage); message CM_TEXTCHANGED; procedure CMDialogChar (var message: TCMDialogChar); message CM_DIALOGCHAR; procedure WMSize (var message: TWMSize); message WM_PAINT; protected procedure Click; override; procedure DrawShape; procedure Paint; override; procedure SetFrameColor (Value: TColor); procedure SetFrameWidth (Value: Integer); procedure SetCornerRadius (Value: Integer); procedure setShape (Value: TShape ); Procedure setTextStyle (Value: TtextStyle); Procedure WmlButtondown (Var Message: Tw Mlbuttondown); Message
WM_LBUTTONDOWN; Procedure WMLButtonup (var message: twmlbutton; message
WM_LBUTTONUP; procedure WriteCaption; public constructor Create (Aowner: TComponent); override; destructor Destroy; override; published property ButtonColor: TColor read FButtonColor write SetButtonColor; property Caption; property DragCursor; property DragMode; property Enabled; property Font; property FrameColor: TColor read FFrameColor write SetFrameColor; property frameWidth: Integer read FFrameWidth write SetFrameWidth; property ParentFont; property ParentShowHint; property PopupMenu; property CornerRadius: Integer read FCornerRadius write SetCornerRadius; property Shape: TShape read FShape write setShape default shRoundRect; property ShowHint; property TextStyle: TTextStyle Read FTextStyle Write setTextStyle; Property Visible; Property OnClick; Property OnDragDrop; Property OnDragover; Property OnMousedown; Property OnMouseu P; Property OnMouseMove;
PROCEDURE register;
IMPLEMENTATION
constructor TDsFancyButton.Create (AOwner: TComponent); begin inherited Create (Aowner); ControlStyle: = [csClickEvents, csCaptureMouse, csSetCaption]; Enabled: = True; FButtonColor: = clBtnFace; FIsDown: = False; FFrameColor: = clGray; FFrameWidth: = 6; fcornerradius: = 10; FRGN: = 0; fshape: = shroundRect; fTextStyle: = txraised; height: = 25; visible: = true; width: = 97;
DeStructor TdsfancyButton.destroy; Begin deleteObject (FRGN); deleteObject (mrgn); inherited destroy;
Procedure tdsfancybutton.paint; var dia: integer; clrup, clrdown: tcolor; begin canvas.brush.style: = bsclear;
if FIsDown then begin ClrUp: = clBtnShadow; ClrDown: = clBtnHighlight; end else begin ClrUp: = clBtnHighlight; ClrDown: = clBtnShadow; end; with Canvas do begin case Shape of shRoundRect: begin Dia: = 2 * CornerRadius; Mrgn: = CreateRoundRectRgn (0, 0, Width, Height, DIA,
DIA); End; Shcapsule: Begin if width Height; mrgn: = CreateroundRectrgn (0, 0, Width, Height, DIA, DIA); end; shRectangle: mrgn: = creterecTrgn (0, 0, width - 1, Height - 1); SHOVAL: MRGN: = CreateellLipTicRGN (0, 0, width, height); end; // case canvas.brush.color: = fbuttoncolor; FillRgn (Handle, MRGN, brush.handle; brush.color: = Framergn (Handle, MRGN, Brush.Handle, 1, 1); OffsetRGN (MRGN, 1, 1); brush.color: = CLRDown; Framergn (Handle, MRGN, Brush.handle, 1, 1); // canvas drawshape; write; Procedure TdsfancyButton.drawshape; Var FC, Warna: Tcolor; R, G, B: Byte; Awalr, Awalg, Awalb, Akhirr, Akhirg, Akhirb, N, T, DIA: Integer; Begin IF FFRAMEWIDTH MOD 2 = 0 THEN T: = FframeWidth else T: = fframewidth 1; WARNA: = ColorTorgb (ButtonColor); Fc: = Colortorgb (Framecolor); canvas.brush.color: = Warna; Akhirr: = getrvalue (war); Akhang: = getBValue (Warna); Akalb: = getBValue (FC); Akhirb: = getBValue (Warna); frGn: = 0; with canvas do for n: = 0 to t - 1 do begin r: = AWALR TRUNC (SQRT (T * T - SQR (TN)) * (Akhirr - AwALR) / T); g: = Awalg Trunc (SQRT (T * T - SQR (TN)) * (Akhirg - Awalg) / T); B: = AWALB TRUNC (SQRT (T * T - SQR (TN)) * (AkhiRB - Awalb) / T) Brush.color: = RGB (R, G, B); Case Shape of Shoval: frGn: = CreatellipticRGN (1 n, 1 n, width - n, Height - n); ShroundRect: Begin Dia: = Cornerradius; IF (DIA - N)> 0 THEN FRGN: = CreateroundRectrgn (1 N, 1 N, Width - N, Height - N, 2 * (DIA - N), 2 * (DIA - N)) ELSE FRGN: = CreateRectrGN (1 N, 1 N, Width - N - 1, Height - N - 1); End; Shcapsule: Begin if Width Height Div 2; IF (Dia - N)> 0 Then FRGN: = CREATEROUNDRGN (1 N, 1 N, Width - N, HEIGHT - N, 2 * (DIA - N), 2 * (DIA - N)) Else Frgn: = CreateRectrGN (1 N, 1 N, Width - N - N 1, Height - N - 1); END; Else FRGN: = CreateRectrgn (1 N, 1 N, Width - N - 1, Height - n - 1); end; // case framergn (Handle, FRGN, Brush.handle, 1, 1); end; End; Procedure tdsfancyButton.Writecaption; Var flags: Word; BTNL, BTNT, BTNR, BTNB: Integer; R, Tr: TRECT; begin r: = clientRect; tr: = clientRect; canvas.font: = self.font; canvas.brush. STYLE: = BSCLEAR; FLAGS: = DT_Center OR DT_SINGLINE; Canvas.Font: = font; if fisdown kil extColor: = framecolor else fTextColor: = Self.font.color; WITH Canvas Do Begin BTNT: = (Height - TextHeight (CAPTION)) DIV 2; BTNB: = BTNT TextHeight (CAPTION); BTNL: = (Width - Textwidth (CAPTION)) DIV 2; btnr: = btnl TextWidth (CAPTION ); Tr: = RECT (BTNL, BTNT, BTNR, BTNB); R: = tr; if ((TextStyle = TXLOWERED) AND FISDOWN OR ((TextStyle = txraiad) and not fisdown) THEN BEGIN FONT.COLOR: = CLBTNHIGHLIGHT ; OffsetRect (Tr, -1 1, -1 1); DrawText (Handle, Pchar (CAPTION), Length (Caption), TR, Flags); end else if ((TextStyle = txLowered) and not FIsDown) or ((TextStyle = txRaised) and FIsDown) then begin Font.Color: = clBtnHighLight; OffsetRect (TR, 2, 2); DrawText (Handle, Pchar (Caption), Length (CAPTION), TR, Flags); Else if (TextStyle = TXSHADOWED) AND FISDOWN THEN BEGIN FONT.COLOR: = CLBTNSHADOW; OffsetRect (Tr, 3 1, 3 1); DrawText (Handle, Pchar (CAPTION), Length (Caption), Tr, Flags; ELSE IF (TextStyle = TXSHADOWED) and NOT FISDOWN The begin font.color: = CLBTNSHADOW; OffsetRECT (Tr, 2 1, 2 1); DrawText (Handle, Pchar (CAPTION), Length (Caption), Tr, Flags; if Enabled then Font.Color: = FTextColor // self.Font.Color else if (TextStyle = txShadowed) and not Enabled then Font.Color: = clBtnFace else Font.Color: = clBtnShadow; if FIsDown then OffsetRect (R, 1, 1) Else OffsetRECT (R, -1, -1); DrawText (Handle, Pchar (CAPTION), Length (Caption), R, Flags); end; Procedure tdsfancyButton.setButtonColor (Value: tcolor); Begin IF Value <> FButtonColor the Begin FB /TONCOLOR: = value; invalidate; end; Procedure TdsfancyButton.wmlbuttondown (Var Message: TWMLBUTTONDOWN; Begin if not PtinRegion (mrgn, message.xpos, message.ypos).. Procedure tdsfancyButton.wmlbuttonup (var message: twmlbutton); begin if not fisdown kiln ixit; fundown: = false; Procedure tdsfancyButton.Setshape (Value: Tshape); Begin IF Value <> fshape dam fshape: = value; invalidate; end; Procedure tdsfancyButton.SettextStyle (Value: TtextStyle); Begin IF Value <> fTextStyle The Begin fTextStyle: = value; invalidate; end; Procedure tdsfancyButton.SetFramecolor (Value: tcolor); Begin if Value <> fframecolor dam fframecolor: = value; invalidate; end; procedure TDsFancyButton.SetFrameWidth (Value: Integer); var w: integer; begin if Width height then w <: = Width else w: = Height; if Value <> FFrameWidth then FFrameWidth: = value; if FFrameWidth <4 then FFrameWidth: = 4; if FFrameWidth> (w div 2) then FFrameWidth: = (w div 2); Invalidate; end; procedure TDsFancyButton.SetCornerRadius (Value: integer); var w: integer; begin if Width Procedure tdsfancybutton.cmenabledchanged (var message: tMessage); begin inherited; Procedure TdsfancyButton.cmTextChanged (Var Message: tMessage); begin invalidate; Procedure tdsfancyButton.cmdialogchar (var message: tcmdialogchar); Begin with message DO if ISAccel (charcode, caption) and enabled dam clicks; result: = 1; end else inherited Procedure tdsfancybutton.wmsize (var message: twmsize); begin inherited; if width> 300 Then Width: = 300; if Height> 300 Then Height: = 300; Procedure tdsfancybutton.click; begin fisdown: = false; invalidate; inherited click; Procedure Register; Begin RegisterComponents ('WYM Component', [TDSFANCyButton]); End.
