Quantcast
Channel: Delphi Forum - Delphi Programming Kings of Code - Delphi Programming
Viewing all articles
Browse latest Browse all 173

new fmx button source

$
0
0
Code:
 unit ufxSuperButton;

interface
uses
ufxClasses,
System.SysUtils, System.Types, System.UITypes, System.Classes, System.Variants,{System.Contnrs,}
FMX.Objects,FMX.Ani,FMX.Types,FMX.Layouts,FMX.Controls,
FMX.Graphics, FMX.StdCtrls;
Const
{$region 'PngByte'}
PngByte: array [0 .. 514] of Byte = (
$89,$50,$4E,$47,$0D,$0A,$1A,$0A,$00,$00,$00,$0D,$49,$48,$44,$52,$00,$00,$00,$14,​
$00,$00,$00,$14,$08,$06,$00,$00,$00,$8D,$89,$1D,$0D,$00,$00,$01,$CA,$49,$44,$41,​
$54,$38,$8D,$CD,$93,$3B,$4F,$1B,$41,$10,$C7,$FF,$FB,$B8,$3B,$3B,$E6,$E4,$10,$D9,​
$91,$62,$0C,$0D,$E2,$D1,$46,$16,$69,$C3,$07,$C0,$55,$44,$41,$93,$12,$AA,$54,$E6,​
$03,$F0,$05,$5C,$51,$71,$1F,$00,$0A,$44,$05,$0D,$1D,$B4,$96,$5C,$22,$11,$2B,$20,​
$25,$91,$6D,$41,$9C,$97,$CE,$70,$3E,$DF,$63,$28,$4E,$7B,$BA,$F8,$52,$61,$23,$31,​
$D5,$FE,$67,$66,$7F,$3B,$3B,$B3,$0B,$4C,$D8,$18,$00,$CC,$7E,$DA,$9B,$D7,$99,$C8,​
$02,$64,$3C,$12,$E3,$0E,$29,$70,$BE,$EF,$6E,$5D,$49,$AC,$AF,$0B,$9D,$F1,$97,$00,​
$8D,$51,$17,$19,$3A,$E3,$06,$00,$70,$1C,$1E,$06,$63,$90,$52,$C6,$27,$09,$7B,$12,​
$A0,$1C,$75,$FC,$F0,$DF,$2D,$12,$65,$4D,$00,$30,$78,$AF,$93,$17,$17,$DD,$51,$BF,​
$8A,$B9,$61,$A1,$04,$00,$8C,$39,$76,$51,$36,$5A,$29,$E0,$F5,$E0,$E3,$1E,$41,$AF,​
$28,$6D,$07,$0B,$B8,$0B,$CB,$B5,$92,$76,$7A,$6E,$FB,$CB,$B5,$64,$6C,$10,$16,$2C,​
$8F,$A6,$37,$01,$80,$61,$D8,$2C,$CA,$C6,$16,$90,$B8,$72,$7B,$B8,$B6,$A6,$36,$68,​
$EC,$B7,$05,$84,$1D,$00,$70,$82,$F2,$CE,$1D,$CD,$4C,$19,$FC,$D7,$B1,$CA,$D5,$78,​
$AF,$2E,$79,$FF,$73,$A4,$C8,$9E,$12,$5F,$2D,$15,$8B,$81,$2E,$15,$36,$A2,$55,$D8,​
$99,$33,$8E,$2C,$8D,$FD,$3D,$89,$34,$33,$FF,$78,$6F,$57,$35,$66,$77,$93,$B7,$71,​
$82,$F2,$0E,$00,$98,$E2,$CB,$F6,$6B,$ED,$BC,$99,$02,$12,$C9,$A5,$A8,$7C,$FF,$9F,​
$8D,$00,$10,$90,$51,$4A,$6A,$C9,$9C,$8E,$5A,$DF,$87,$B3,$1B,$C9,$58,$0C,$14,$6C,​
$70,$06,$00,$04,$BD,$72,$EB,$BD,$AF,$F8,$94,$8B,$FB,$95,$97,$97,$C7,$1E,$99,$6F,​
$94,$F6,$29,$5B,$CA,$F0,$9B,$7A,$74,$58,$66,$F5,$9B,$FB,$61,$33,$05,$CC,$89,$96,​
$05,$90,$0D,$00,$76,$B0,$10,$0F,$47,$E3,$FD,$FD,$BC,$B8,$E8,$BA,$E1,$AB,$AA,$CA,​
$F5,$C2,$42,$2D,$59,$B5,$1A,$0E,$90,$98,$72,$51,$36,$5A,$2F,$44,$BB,$FA,$D3,$5B,​
$A9,$82,$84,$09,$00,$19,$DE,$6B,$AA,$FE,$98,$F2,$B2,$FE,$9F,$67,$13,$F7,$2E,$05,​
$04,$80,$1C,$6B,$F7,$73,$7A,$FB,$60,$34,$49,$1D,$98,$72,$0A,$A4,$FA,$FD,$FC,$BF,​
$DE,$D3,$00,$7D,$1F,$F7,$E3,$82,$28,$88,$5E,$C8,$C4,$ED,$01,$74,$0B,$B0,$81,$2C,​
$D7,$7D,$80,$00,$00,$00,$00,$49,$45,$4E,$44,$AE,$42,$60,$82);
{$Endregion}
Const
BColor=$00006AFF;
EColor=$32006AFF;
DColor=$50006AFF;
PColor=$80006AFF;
Type
TfxSuperButton=Class;
TfxTextSettings=Class(TTextSettings)
published
property Font;
property FontColor;
property HorzAlign;
property VertAlign;
property WordWrap;
End;

TfxButtonType=Class(TPersistent)
private
FOwner: TPersistent;
FTextSettings:TfxTextSettings;
FText:String;

FData:TPathData;
FMargin:Single;
FFillColor:TAlphaColor;
FBmp:TBitmap;
//绘制
Procedure DoPaint(ACanvas:TCanvas;ARect:TRectf);virtual;abstract;
public
constructor Create(AOwner:TPersistent);overload; virtual;
destructor Destroy; override;
End;

TfxTextButton=Class(TfxButtonType)
private
Procedure SetTextSettings(Value:TfxTextSettings);
Procedure DoPaint(ACanvas:TCanvas;ARect:TRectf);override;
published
Property Text:String Read FText Write FText;
Property TextSettings:TfxTextSettings Read FTextSettings Write SetTextSettings;
End;

TfxPathButton=Class(TfxButtonType)
private
Procedure SetData(Value:TPathData);
Procedure DoPaint(ACanvas:TCanvas;ARect:TRectf);override;
published
Property Margin:Single Read FMargin Write FMargin;
Property Data:TPathData Read FData Write SetData;
Property FillColor:TAlphaColor Read FFillColor Write FFillColor;
End;

TfxImageButton=Class(TfxButtonType)
private
Procedure SetBmp(Value:TBitmap);
Procedure DoPaint(ACanvas:TCanvas;ARect:TRectf);override;
published
Property Bitmap:TBitmap Read FBmp Write SetBmp;
Property Margin:Single Read FMargin Write FMargin;
End;

TfxButtonTypeClass = class of TfxButtonType;
TfxSuperButton=Class(TControl,IDesign)
private
{IDesign}
Function GetX:Single;
Procedure SetX(Value:Single);
Function GetY:Single;
Procedure SetY(Value:Single);
Function GetW:Single;
Procedure SetW(Value:Single);
Function GetH:Single;
Procedure SetH(Value:Single);
Function GetV:Boolean;
Function GetItemsClasses:TItemsClasses;
Function IsTree:Boolean;
Procedure SelItem(AObj:TObject);
//控制器事件
Procedure OnDblClickProc;//双击
Function BeforeMouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Single):Boolean;//按下鼠标前
Procedure AfterMouseDown (Button: TMouseButton; Shift: TShiftState; X, Y: Single);//按下鼠标后
//inheritance
private
FXRadius:Single;
FYRadius:Single;
FCorners:TCorners;

FEnter :Boolean;//当鼠标滑过时
FDown :Boolean;//当鼠标按下时
FIsPressed :Boolean;
FStayspressed :Boolean;
FPropertyPressed:Boolean;

FColorPressed:TAlphaColor;
FColorBegin :TAlphaColor;
FColorEnter :TAlphaColor;
FColorDown :TAlphaColor;

FButtonType :TfxButtonType;
FButtonTypeClass:TfxButtonTypeClass;
Function GetColorBegin:TAlphaColor;
Procedure SetColorBegin(Value:TAlphaColor);
Procedure SetIsPressed(Value:Boolean);
Procedure SetStayspressed(Value:Boolean);
Procedure SetButtonType(Value:TfxButtonType);
Procedure SetButtonTypeClass(Value:TfxButtonTypeClass);
Function GetButtonTypeClassName:String;
Procedure SetButtonTypeClassName(Value:String);

procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Single); override;
procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Single); override;
procedure MouseClick(Button: TMouseButton; Shift: TShiftState; X, Y: Single);override;
procedure DoMouseEnter; override;
procedure DoMouseLeave; override;
procedure Paint; override;
procedure SetName(const NewName: TComponentName);override;
public
Property ButtonTypeClass:TfxButtonTypeClass Read FButtonTypeClass Write SetButtonTypeClass;
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
published
Property XRadius :Single Read FXRadius Write FXRadius;
Property YRadius :Single Read FYRadius Write FYRadius;
Property Corners :TCorners Read FCorners Write FCorners;

Property ColorBegin :TAlphaColor Read GetColorBegin Write SetColorBegin default BColor;
Property ColorEnter :TAlphaColor Read FColorEnter Write FColorEnter default EColor;
Property ColorDown :TAlphaColor Read FColorDown Write FColorDown default DColor;
Property ColorPressed :TAlphaColor Read FColorPressed Write FColorPressed default PColor;

Property IsPressed :Boolean Read FIsPressed Write SetIsPressed default False;
Property Stayspressed :Boolean Read FStayspressed Write SetStayspressed default False;


Property ButtonTypeClassName :String Read GetButtonTypeClassName Write SetButtonTypeClassName;
Property ButtonType :TfxButtonType Read FButtonType Write SetButtonType;

property Align;
property Anchors;
property ClipChildren;
property ClipParent;
property Cursor;
property DragMode;
property EnableDragHighlight;
property Enabled;
property Locked;
property Height;
property HitTest default False;
property Padding;
property Opacity;
property Margins;
property PopupMenu;
property Position;
property RotationAngle;
property RotationCenter;
property Scale;
property Size;
property TouchTargetExpansion;
property Visible;
property Width;
property TabOrder;
property TabStop;
{ Events }
property OnPainting;
property OnPaint;
property OnResize;
{ Drag and Drop events }
property OnDragEnter;
property OnDragLeave;
property OnDragOver;
property OnDragDrop;
property OnDragEnd;
{ Mouse events }
property OnClick;
property OnDblClick;
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
property OnMouseWheel;
property OnMouseEnter;
property OnMouseLeave;
End;

Procedure AddCusetomControl;
Procedure DelCusetomControl;
implementation
uses
{$IFNDEF NEXTGEN}
ufxDesign.Reg,ufxDesign.RttiInfo,FMX.Forms,
{$ENDIF}
System.Math;
{--------------------------}
{TfxButtonType}
constructor TfxButtonType.Create(AOwner:TPersistent);
Begin
inherited Create;
FOwner:=AOwner;
FTextSettings:=TfxTextSettings.Create(FOwner);
FTextSettings.HorzAlign:=TTextAlign.Center;
FText:=TfxSuperButton(FOwner).Name;

FData:=TPathData.Create;
FFillColor:=TAlphaColorRec.Black;

FBmp:=TBitmap.Create;
FMargin:=0;
End;

destructor TfxButtonType.Destroy;
Begin
Freeandnil(FTextSettings);
Freeandnil(FData);
Freeandnil(FBmp);
inherited Destroy;
End;
{TfxTextButton}
Procedure TfxTextButton.SetTextSettings(Value:TfxTextSettings);
Begin
FTextSettings.Assign(Value);
End;
Procedure TfxTextButton.DoPaint(ACanvas:TCanvas;ARect:TRectf);
Begin
ACanvas.Font.Assign(FTextSettings.Font);
ACanvas.Fill.Color:=FTextSettings.FontColor;
ACanvas.FillText(ARect,FText,FTextSettings.WordWrap,1,,FTextSettings.HorzAlign,F​TextSettings.VertAlign);
End;
{TfxPathButton}
Procedure TfxPathButton.SetData(Value:TPathData);
Begin
FData.Assign(Value);
End;
Procedure TfxPathButton.DoPaint(ACanvas:TCanvas;ARect:TRectf);
Var
iPD:TPathData;
Len:Single;
Begin
iPD:=TPathData.Create;
Try
iPD.Data:=FData.Data;
Len:=Min(ARect.Width,ARect.Height)-FMargin*2;

iPD.Scale(Len/iPD.GetBounds.Width,Len/iPD.GetBounds.Height);//缩放

iPD.Translate(Pointf(ARect.Width/2-Len/2,ARect.Height/2-Len/2));

ACanvas.Fill.Color:=FFillColor;
ACanvas.FillPath(iPD,1);
Finally
iPD.Free;
End;

End;
{TfxImageButton}
Procedure TfxImageButton.SetBmp(Value:TBitmap);
Begin
FBmp.Assign(Value);
End;
Procedure TfxImageButton.DoPaint(ACanvas:TCanvas;ARect:TRectf);
Var
Len:Single;
Begin
if (FBmp=Nil)Or(FBmp.IsEmpty) then
Exit;

Len:=Min(ARect.Width,ARect.Height)-FMargin*2;
ACanvas.BeginScene;
ACanvas.DrawBitmap(FBmp,
Rectf(0,0,FBmp.Width,FBmp.Height),
Rectf(ARect.Width/2-Len/2,ARect.Height/2-Len/2,ARect.Width/2+Len/2,ARect.Height/2+Len/2),
1);
ACanvas.EndScene;
End;
{TfxSuperButton}
Function TfxSuperButton.GetX:Single;
Begin
Exit(Self.Position.X);
End;
Procedure TfxSuperButton.SetX(Value:Single);
Begin
Self.Position.X:=Value;
End;
Function TfxSuperButton.GetY:Single;
Begin
Exit(Self.Position.Y);
End;
Procedure TfxSuperButton.SetY(Value:Single);
Begin
Self.Position.Y:=Value;
End;
Function TfxSuperButton.GetW:Single;
Begin
Exit(Self.Width);
End;
Procedure TfxSuperButton.SetW(Value:Single);
Begin
Self.Width:=Value;
End;
Function TfxSuperButton.GetH:Single;
Begin
Exit(Self.Height);
End;
Procedure TfxSuperButton.SetH(Value:Single);
Begin
Self.Height:=Value;
End;

Function TfxSuperButton.GetV:Boolean;
Begin
Exit(Self.Visible);
End;

Function TfxSuperButton.GetItemsClasses:TItemsClasses;
Begin
raise Exception.Create('Does not support "Items Editor"');
End;

Function TfxSuperButton.IsTree:Boolean;
Begin
Exit(False);
End;

Procedure TfxSuperButton.SelItem(AObj:TObject);
Begin

End;

Procedure TfxSuperButton.OnDblClickProc;
Begin

End;

Function TfxSuperButton.BeforeMouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Single):Boolean;//按下鼠标前
Begin
Exit(True);
End;
Procedure TfxSuperButton.AfterMouseDown (Button: TMouseButton; Shift: TShiftState; X, Y: Single);//按下鼠标后
Begin

End;

Function TfxSuperButton.GetColorBegin:TAlphaColor;
Begin
Exit(FColorBegin);
End;
Procedure TfxSuperButton.SetColorBegin(Value:TAlphaColor);
Begin
FColorBegin:=Value;
Repaint;
End;

Procedure TfxSuperButton.SetIsPressed(Value:Boolean);
Begin
if (not FStayspressed)And (FPropertyPressed) then
Exit;

FIsPressed:=Value;
if FIsPressed then
Begin
FEnter:=False;
FDown :=False;
End;
Repaint;
End;

Procedure TfxSuperButton.SetStayspressed(Value:Boolean);
Begin
FStayspressed:=Value;
if Not FStayspressed then
IsPressed:=False;

FPropertyPressed:=True;
End;

Procedure TfxSuperButton.SetButtonType(Value:TfxButtonType);
Begin
if (FButtonType<>Nil)And(Value<>Nil) then
FButtonType.AssignTo(Value);
End;

Procedure TfxSuperButton.SetButtonTypeClass(Value:TfxButtonTypeClass);
Begin
if FButtonTypeClass <> Value then
begin
if FButtonType <> nil then
FreeAndnil(FButtonType);

FButtonTypeClass:=Value;

FButtonType:=FButtonTypeClass.Create(Self);
end;
End;

Function TfxSuperButton.GetButtonTypeClassName:String;
Begin
if FButtonType = nil then
Exit('');

Exit(FButtonType.ClassName);
End;
Procedure TfxSuperButton.SetButtonTypeClassName(Value:String);
Var
iClass:TClass;
Begin
iClass:=FindClass(Value);
if (iClass<>Nil)And iClass.InheritsFrom(TfxButtonType) then
ButtonTypeClass:=TfxButtonTypeClass(iClass);
End;

procedure TfxSuperButton.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Single);
Begin
inherited;
if (Button=TMouseButton.mbLeft)And(Not FIsPressed) then
Begin
FDown:=True;
Repaint;
End;

End;
procedure TfxSuperButton.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Single);
Begin
inherited;
if FDown then
Begin
FDown:=False;
Repaint;
End;
End;

procedure TfxSuperButton.MouseClick(Button: TMouseButton; Shift: TShiftState; X, Y: Single);
Begin
inherited;
if FStayspressed then
IsPressed:=Not IsPressed;

if Not IsPressed then
Begin
FEnter:=True;
Repaint;
End;
End;
procedure TfxSuperButton.DoMouseEnter;
Begin
inherited;
if Not FIsPressed then
Begin
FEnter:=True;
Repaint;
End;
End;
procedure TfxSuperButton.DoMouseLeave;
Begin
inherited;
FEnter:=False;
FDown :=False;
Repaint;
End;

procedure TfxSuperButton.Paint;
Begin
inherited;
if FDown then
Canvas.Fill.Color:=FColorDown
Else
if FEnter then
Canvas.Fill.Color:=FColorEnter
Else
if FIsPressed then
Canvas.Fill.Color:=FColorPressed
Else
Canvas.Fill.Color:=FColorBegin;

Canvas.FillRect(Rectf(0,0,Width,Height),XRadius,YRadius,Corners,1);

if FButtonType<>Nil then
FButtonType.DoPaint(Canvas,Rectf(0,0,Width,Height));

End;

procedure TfxSuperButton.SetName(const NewName: TComponentName);
Begin
if (FButtonType<>Nil)
And(FButtonType is TfxTextButton)
And(TfxTextButton(FButtonType).Text=Name) then
TfxTextButton(FButtonType).Text:=NewName;

inherited;
End;

constructor TfxSuperButton.Create(AOwner:TComponent);
Begin
inherited Create(AOwner);
Width:=100;
Height:=25;

FColorPressed:=PColor;
FColorBegin :=BColor;
FColorEnter :=EColor;
FColorDown :=DColor;

FEnter :=False;//当鼠标滑过时
FDown :=False;//当鼠标按下时
FIsPressed :=False;
FStayspressed:=False;

HitTest :=True;

FPropertyPressed:=False;

FXRadius:=0;
FYRadius:=0;
FCorners:=AllCorners;
End;

destructor TfxSuperButton.Destroy;
Begin
if FButtonType<>Nil then
Freeandnil(FButtonType);
inherited Destroy;
End;
{$IFNDEF NEXTGEN}
Var
ConBitmap:TBitmap;
Procedure AddCusetomControl;
Var
iStream: TMemoryStream;
Begin
iStream:=TMemoryStream.Create;
ConBitmap:=TBitmap.Create;
Try
iStream.Write(PngByte, High(PngByte));
iStream.Position:=0;
ConBitmap.LoadFromStream(iStream);
CustomObject.RegisterObject('Standard',TfxSuperButton,ConBitmap);
Finally
FreeAndNil(iStream);
End;
{$ELSE}
Procedure AddCusetomControl;
Begin
{$ENDIF}
RegisterClass(TfxSuperButton);

RegisterClass(TfxTextButton);
RegisterClass(TfxPathButton);
RegisterClass(TfxImageButton);

GetAddPaxRegs.Add(TfxSuperButton)
End;

Procedure DelCusetomControl;
Begin
UnRegisterClass(TfxSuperButton);

UnRegisterClass(TfxTextButton);
UnRegisterClass(TfxPathButton);
UnRegisterClass(TfxImageButton);
{$IFNDEF NEXTGEN}
CustomObject.Unregister(TfxSuperButton);

IF Assigned(ConBitmap) THEN
FreeAndNil(ConBitmap)
End;
{$region 'TfxButtonTypeProperty'}
Type
TfxButtonTypeProperty=Class(TfxPropertyEditor)
Public
function GetAttributes: TfxRttiPropertyAttributes; override;
Function GetValues : String; override;
function GetValue : string; override;
procedure SetValue (const Value: string); override;
End;

function TfxButtonTypeProperty.GetAttributes: TfxRttiPropertyAttributes;
Begin
Exit([paMultiSelect, paValueList, paSortList,paSubProperties])
End;
Function TfxButtonTypeProperty.GetValues : String;
Begin
Exit('TfxTextButton'+#$d#$a
+'TfxPathButton'+#$d#$a
+'TfxImageButton');
End;
function TfxButtonTypeProperty.GetValue : string;
Begin
if TfxSuperButton(RttiPropertyItem.ParentObj).ButtonTypeClass=nil then
Exit('');

Exit(TfxSuperButton(RttiPropertyItem.ParentObj).ButtonTypeClass.ClassName);
End;
procedure TfxButtonTypeProperty.SetValue (const Value: string);
Begin
TfxSuperButton(RttiPropertyItem.ParentObj).ButtonTypeClass:=TfxButtonTypeClass(F​indClass(Value));
RttiPropertyItem.OnRefInspector();
End;
{$Endregion}
initialization
fxRegisterPropertyEditor(TypeInfo(TfxButtonType),TfxSuperButton,'',TfxButtonType​Property);
fxRegisterPropertyEditor(TypeInfo(String),TfxSuperButton,'ButtonTypeClassName',n​il);
{$ELSE}
End;
{$ENDIF}
end.

 

 

Viewing all articles
Browse latest Browse all 173

Trending Articles



<script src="https://jsc.adskeeper.com/r/s/rssing.com.1596347.js" async> </script>