nSpeedButton
Olá pessoal:
Andei procurando muito na net um speedbutton que tivesse a opção ImgList não achei
resolvi criar um.
Adicionei várias outras novidades:
Opção GrayScale - > para o botão fica com a cor cinsa quando desabilitado ou com transparente com a opção Opacity.
Opções GlyphOver e GlyphDown e também com ImgList.
Suporta: Bitmap 32 Bits, mas se estiver instalado o Component TPNGGraphics no seu delphi vai aceitar png também.
Estou postando para quem estiver precisando:
Previa:
[url=https://postimg.org/image/dtxecd6vp/][img]https://s10.postimg.org/dtxecd6vp/Sem_t_tulo.jpg[/img][/url]
https://youtu.be/iiKtrm2zN0w
download Install dpk nSpeedButton
http://www.mediafire.com/download/oqm3pea1ouy29af/Button2.rar
http://www.4shared.com/rar/Fz1C6wTbba/Button2.html
se quiser o TPNGGraphics:
http://www.mediafire.com/download/ct11e5avx26m0s2/PngGraphics.rar
http://www.4shared.com/rar/-hTI0WoGce/PngGraphics.html
Se vc não Gosta de instar qualquer component em seu delphi pode usar em runtime mesmo:
Andei procurando muito na net um speedbutton que tivesse a opção ImgList não achei
resolvi criar um.
Adicionei várias outras novidades:
Opção GrayScale - > para o botão fica com a cor cinsa quando desabilitado ou com transparente com a opção Opacity.
Opções GlyphOver e GlyphDown e também com ImgList.
Suporta: Bitmap 32 Bits, mas se estiver instalado o Component TPNGGraphics no seu delphi vai aceitar png também.
Estou postando para quem estiver precisando:
Previa:
[url=https://postimg.org/image/dtxecd6vp/][img]https://s10.postimg.org/dtxecd6vp/Sem_t_tulo.jpg[/img][/url]
https://youtu.be/iiKtrm2zN0w
download Install dpk nSpeedButton
http://www.mediafire.com/download/oqm3pea1ouy29af/Button2.rar
http://www.4shared.com/rar/Fz1C6wTbba/Button2.html
se quiser o TPNGGraphics:
http://www.mediafire.com/download/ct11e5avx26m0s2/PngGraphics.rar
http://www.4shared.com/rar/-hTI0WoGce/PngGraphics.html
Se vc não Gosta de instar qualquer component em seu delphi pode usar em runtime mesmo:
unit Button2;
interface
uses Windows, Messages, Classes, Controls, Forms, Graphics, StdCtrls,
ExtCtrls, CommCtrl, ImgList;
type
TnRGB = packed record
B, G, R: Byte;
end;
TnRGBA = packed record
B, G, R, A: Byte;
end;
TnColor = record
case integer of
0 : (C : TColor);
1 : (R, G, B, A : Byte);
2 : (I : integer);
3 : (nsBGRA : TnRGBA);
4 : (RGB : TnRGB; nMASK : Byte);
end;
TnColor_ = record
case integer of
0 : (C : TColor);
1 : (B, G, R, A : Byte);
2 : (I : integer);
3 : (nBGRA : TnRGBA);
4 : (BGR : TnRGB; nMASK : Byte);
end;
PRGBAArray = ^TRGBAArray;
TRGBAArray = array[0..100000] of TnColor_;
TButtonLayout = (blImageLeft, blImageRight, blImageTop, blImageBottom);
TButtonState = (bsUp, bsDisabled, bsDown, bsExclusive);
TButtonStyle = (bsAutoDetect, bsWin31, bsNew);
TNumGlyphs = 1..4;
TEnabledImage_e_Glyphs = (bsGrayScale, bsOpacity);
TEnabled_IGs = set of TEnabledImage_e_Glyphs;
TnSpeedButton = class;
TcSpeedButtonActionLink = class(TControlActionLink)
protected
FClient: TnSpeedButton;
procedure AssignClient(AClient: TObject); override;
function IsCheckedLinked: Boolean; override;
function IsGroupIndexLinked: Boolean; override;
procedure SetGroupIndex(Value: Integer); override;
procedure SetChecked(Value: Boolean); override;
end;
TnSpeedButton = class(TGraphicControl)
private
FOriginal : TBitmap;
FOriginalOver : TBitmap;
FOriginalDown : TBitmap;
FIndexs: array[TButtonState] of Integer;
FTransparentColor: TColor;
FImageList: TCustomImageList;
FGlyphImgList : TImageList;
FInternalImageList: TImageList;
FImageChangeLink: TChangeLink;
FImageIndex: TImageIndex;
FDown: Boolean;
FDragging: Boolean;
FAllowAllUp: Boolean;
FLayout: TButtonLayout;
FSpacing: Integer;
FTransparent: Boolean;
FMargin: Integer;
FFlat: Boolean;
FMouseInControl: Boolean;
FEOpacity: integer;
FEnabledGrayScale: TEnabled_IGs;
FGroupIndex: Integer;
FOnChange: TNotifyEvent;
FOnMouseLeave, FOnMouseEnter: TNotifyEvent;
FOverDraw : Boolean;
FOverIndexOver, FOverIndexNormal, FOverIndexDown: Integer;
FImgOvSize: Boolean;
FImgOvNoFlat: Boolean;
function CreateButtonGlyph2(State: TButtonState): Integer;
procedure DrawButtonGlyph(Canvas: TCanvas; const GlyphPos: TPoint;
State: TButtonState; Transparent, SetGrayScaleAndOpacity: Boolean);
procedure DrawButtonImgList(Canvas: TCanvas; const GlyphPos: TPoint;
State: TButtonState; Transparent, SetGrayScaleAndOpacity: Boolean);
procedure DrawButtonText(Canvas: TCanvas; const Caption: string;
TextBounds: TRect; State: TButtonState; BiDiFlags: Longint);
procedure CalcButtonLayout(Canvas: TCanvas; const Client: TRect;
const Offset: TPoint; const Caption: string; Layout: TButtonLayout;
Margin, Spacing: Integer; var GlyphPos: TPoint; var TextBounds: TRect;
BiDiFlags: Longint);
procedure GlyphChanged(Sender: TObject);
procedure UpdateExclusive;
procedure SetGlyph(Value: TBitmap);
procedure SetGlyphOver(const Value: TBitmap);
procedure SetGlyphDown(const Value: TBitmap);
procedure SetDown(Value: Boolean);
procedure SetFlat(Value: Boolean);
procedure SetAllowAllUp(Value: Boolean);
procedure SetGroupIndex(Value: Integer);
procedure SetLayout(Value: TButtonLayout);
procedure SetSpacing(Value: Integer);
procedure SetTransparent(Value: Boolean);
procedure SetMargin(Value: Integer);
procedure UpdateTracking;
procedure WMLButtonDblClk(var Message: TWMLButtonDown); message WM_LBUTTONDBLCLK;
procedure CMEnabledChanged(var Message: TMessage); message CM_ENABLEDCHANGED;
procedure CMButtonPressed(var Message: TMessage); message CM_BUTTONPRESSED;
procedure CMDialogChar(var Message: TCMDialogChar); message CM_DIALOGCHAR;
procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
procedure CMTextChanged(var Message: TMessage); message CM_TEXTCHANGED;
procedure CMSysColorChange(var Message: TMessage); message CM_SYSCOLORCHANGE;
procedure CMMouseEnter(var Message: TMessage); message CM_MOUSEENTER;
procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE;
procedure SetEnabledGrayScale(const Value: TEnabled_IGs);
procedure SetEnabledOpacity(const Value: integer);
procedure SetImageIndex(const Value: TImageIndex);
procedure SetImages(const Value: TCustomImageList);
procedure ImageListChange(Sender: TObject);
procedure SetOverDraw(const Value: Boolean);
procedure SetImgOvSize(const Value: Boolean);
procedure SetImgOvNoFlat(const Value: Boolean);
protected
FState: TButtonState;
procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override;
function GetActionLinkClass: TControlActionLinkClass; override;
function GetPalette: HPALETTE; override;
procedure Loaded; override;
procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer); override;
procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer); override;
procedure Paint; override;
property MouseInControl: Boolean read FMouseInControl;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure Click; override;
procedure AlphaTransBitmap(Canvas: TCanvas; const PsW,
PsH: Integer; const SrcBmp: TBitmap; Enabled_GScale_Opacity: Boolean);
function Draw(Canvas: TCanvas; const Client: TRect; const Offset: TPoint;
const Caption: string; Layout: TButtonLayout; Margin, Spacing: Integer;
State: TButtonState; Transparent, SetGrayScaleAndOpacity: Boolean; BiDiFlags: Longint): TRect;
property OnChange: TNotifyEvent read FOnChange write FOnChange;
published
property Action;
property AllowAllUp: Boolean read FAllowAllUp write SetAllowAllUp default False;
property Anchors;
property BiDiMode;
property Constraints;
property GroupIndex: Integer read FGroupIndex write SetGroupIndex default 0;
property Down: Boolean read FDown write SetDown default False;
property Caption;
property Enabled;
property Flat: Boolean read FFlat write SetFlat default False;
property Font;
property Glyph: TBitmap read FOriginal write SetGlyph;
property GlyphDown: TBitmap read FOriginalDown write SetGlyphDown;
property GlyphOver: TBitmap read FOriginalOver write SetGlyphOver;
property Layout: TButtonLayout read FLayout write SetLayout default blImageLeft;
property Margin: Integer read FMargin write SetMargin default -1;
property ParentFont;
property ParentShowHint;
property ParentBiDiMode;
property PopupMenu;
property ShowHint;
property Spacing: Integer read FSpacing write SetSpacing default 4;
property Transparent: Boolean read FTransparent write SetTransparent default True;
property Visible;
property OnClick;
property OnDblClick;
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
property OnMouseEnter : TNotifyEvent read FOnMouseEnter write FOnMouseEnter;
property OnMouseLeave : TNotifyEvent read FOnMouseLeave write FOnMouseLeave;
property ImgOverDraw : Boolean read FOverDraw write SetOverDraw default false;
property ImgOvNoFlatRec : Boolean read FImgOvNoFlat write SetImgOvNoFlat default false;
property ImgOvIdxNormal : Integer read FOverIndexNormal write FOverIndexNormal default 0;
property ImgOvIdxDown : Integer read FOverIndexDown write FOverIndexDown default 1;
property ImgOvIdxOver : Integer read FOverIndexOver write FOverIndexOver default 2;
property ImgOvSize: Boolean read FImgOvSize write SetImgOvSize default false;
property EnabledGrayScale: TEnabled_IGs read FEnabledGrayScale write SetEnabledGrayScale default [bsGrayScale];
property EnabledOpcValue : integer read FEOpacity write SetEnabledOpacity default 50; //50% de 100 a 1
property ImageList: TCustomImageList read FImageList write SetImages;
property ImageIndex: TImageIndex read FImageIndex write SetImageIndex default -1;
end;
//procedure Register;
implementation
uses Consts, SysUtils, ActnList, Themes, Math, DateUtils, Types;
{procedure Register;
begin
RegisterComponents('Standard', [TnSpeedButton]);
end; }
function TnSpeedButton.CreateButtonGlyph2(State: TButtonState): Integer;
var
TmpImage: TBitmap;
IWidth, IHeight: Integer;
IRect, ORect: TRect;
I: TButtonState;
begin
Result := FIndexs[State];
if Result <> -1 then Exit;
if (FOriginal.Width or FOriginal.Height) = 0 then Exit;
IWidth := FOriginal.Width;
IHeight := FOriginal.Height;
TmpImage := TBitmap.Create;
try
TmpImage.Width := IWidth;
TmpImage.Height := IHeight;
FGlyphImgList.Width := TmpImage.Width;
FGlyphImgList.Height := TmpImage.Height;
IRect := Rect(0, 0, IWidth, IHeight);
TmpImage.Canvas.Brush.Color := clBtnFace;
TmpImage.Palette := CopyPalette(FOriginal.Palette);
I := State;
ORect := Rect(Ord(I) * IWidth, 0, (Ord(I) + 1) * IWidth, IHeight);
case State of
bsUp, bsDown,
bsExclusive:
begin
TmpImage.Canvas.CopyRect(IRect, FOriginal.Canvas, ORect);
if FOriginal.TransparentMode = tmFixed then
FIndexs[State] := FGlyphImgList.AddMasked(TmpImage, FTransparentColor)
else
FIndexs[State] := FGlyphImgList.AddMasked(TmpImage, clDefault);
if FOriginalOver <> nil then begin
TmpImage.Palette := CopyPalette(FOriginalOver.Palette);
TmpImage.Canvas.CopyRect(IRect, FOriginalOver.Canvas, ORect);
if FOriginalOver.TransparentMode = tmFixed then
FIndexs[State] := FGlyphImgList.AddMasked(TmpImage, FTransparentColor)
else
FIndexs[State] := FGlyphImgList.AddMasked(TmpImage, clDefault);
end;
if FOriginalDown <> nil then begin
TmpImage.Palette := CopyPalette(FOriginalDown.Palette);
TmpImage.Canvas.CopyRect(IRect, FOriginalDown.Canvas, ORect);
if FOriginalDown.TransparentMode = tmFixed then
FIndexs[State] := FGlyphImgList.AddMasked(TmpImage, FTransparentColor)
else
FIndexs[State] := FGlyphImgList.AddMasked(TmpImage, clDefault);
end;
end;
bsDisabled:
begin
BitBlt(TmpImage.Canvas.Handle, 0, 0, IWidth, IHeight, FOriginal.Canvas.Handle, 0, 0, SRCCOPY);
FIndexs[State] := FGlyphImgList.AddMasked(TmpImage, clDefault);
end;
end;
finally
TmpImage.Free;
end;
Result := FIndexs[State];
FOriginal.Dormant;
FOriginalOver.Dormant;
FOriginalDown.Dormant;
end;
procedure TnSpeedButton.DrawButtonGlyph(Canvas: TCanvas; const GlyphPos: TPoint;
State: TButtonState; Transparent, SetGrayScaleAndOpacity: Boolean);
var
R: TRect;
bmp : TBitmap;
MakeColor : TColor;
procedure PreparingBitmap(IndexToInsert: Integer; ImageListToInsert: TCustomImageList);
begin
Bmp.Width := ImageListToInsert.Width;
Bmp.Height := ImageListToInsert.Height;
Bmp.PixelFormat := pf32bit;
if ImageListToInsert.BkColor <> clNone then
MakeColor := ImageListToInsert.BkColor
else
MakeColor := clFuchsia;
Bmp.Canvas.Brush.Color := MakeColor;
Bmp.Canvas.FillRect(Rect(0, 0, Bmp.Width, Bmp.Height));
ImageListToInsert.GetBitmap(IndexToInsert, Bmp);
end;
begin
if FOriginal = nil then Exit;
if (FOriginal.Width = 0) or (FOriginal.Height = 0) and
((FGlyphImgList = nil) and ((FOverIndexNormal < 0) or (FOverIndexOver < 0) or (FOverIndexDown < 0)) and
((FOverIndexNormal > FGlyphImgList.Count) or (FOverIndexOver > FGlyphImgList.Count) and (FOverIndexDown > FGlyphImgList.Count))) then Exit;
CreateButtonGlyph2(State);
bmp := TBitmap.Create;
if FOverDraw then
begin
if (FState = bsDown) or (Down) then
PreparingBitmap(FOverIndexDown, FGlyphImgList)
else
if MouseInControl then
PreparingBitmap(FOverIndexOver, FGlyphImgList)
else
PreparingBitmap(FOverIndexNormal, FGlyphImgList)
end else
PreparingBitmap(FOverIndexNormal, FGlyphImgList);
with GlyphPos do
begin
if ThemeServices.ThemesEnabled then
begin
R.TopLeft := GlyphPos;
R.Right := R.Left + bmp.Width;
R.Bottom := R.Top + bmp.Height;
AlphaTransBitmap(Canvas, r.Left, r.Top, Bmp, SetGrayScaleAndOpacity);
end else
if Transparent or (State = bsExclusive) then
begin
// ImageList_DrawEx(FGlyphImgList.Handle, FOverIndexNormal, Canvas.Handle, X, Y, 0, 0,
// clNone, clNone, ILD_Transparent);
AlphaTransBitmap(Canvas, GlyphPos.X, GlyphPos.Y, Bmp, SetGrayScaleAndOpacity);
end else begin
// ImageList_DrawEx(FGlyphImgList.Handle, FOverIndexNormal, Canvas.Handle, X, Y, 0, 0,
// ColorToRGB(clBtnFace), clNone, ILD_Normal);
AlphaTransBitmap(Canvas, GlyphPos.X, GlyphPos.Y, Bmp, SetGrayScaleAndOpacity);
end;
FreeAndNil(bmp);
end;
end;
procedure TnSpeedButton.DrawButtonText(Canvas: TCanvas; const Caption: string;
TextBounds: TRect; State: TButtonState; BiDiFlags: LongInt);
begin
with Canvas do
begin
Brush.Style := bsClear;
if State = bsDisabled then
begin
OffsetRect(TextBounds, 1, 1);
Font.Color := clBtnHighlight;
DrawText(Handle, PChar(Caption), Length(Caption), TextBounds,
DT_CENTER or DT_VCENTER or BiDiFlags);
OffsetRect(TextBounds, -1, -1);
Font.Color := clGrayText;
DrawText(Handle, PChar(Caption), Length(Caption), TextBounds,
DT_CENTER or DT_VCENTER or BiDiFlags);
end else
DrawText(Handle, PChar(Caption), Length(Caption), TextBounds, DT_CENTER or DT_VCENTER or BiDiFlags);
end;
end;
procedure TnSpeedButton.CalcButtonLayout(Canvas: TCanvas; const Client: TRect;
const Offset: TPoint; const Caption: string; Layout: TButtonLayout; Margin,
Spacing: Integer; var GlyphPos: TPoint; var TextBounds: TRect;
BiDiFlags: LongInt);
var
TextPos: TPoint;
ClientSize, GlyphSize, TextSize: TPoint;
TotalSize: TPoint;
begin
if (BiDiFlags and DT_RIGHT) = DT_RIGHT then
if Layout = blImageLeft then Layout := blImageRight
else
if Layout = blImageRight then Layout := blImageLeft;
{ calculate the item sizes }
ClientSize := Point(Client.Right - Client.Left, Client.Bottom - Client.Top);
if FOriginal <> nil then
GlyphSize := Point(FOriginal.Width, FOriginal.Height) else
GlyphSize := Point(0, 0);
if Length(Caption) > 0 then
begin
TextBounds := Rect(0, 0, Client.Right - Client.Left, 0);
DrawText(Canvas.Handle, PChar(Caption), Length(Caption), TextBounds,
DT_CALCRECT or BiDiFlags);
TextSize := Point(TextBounds.Right - TextBounds.Left, TextBounds.Bottom -
TextBounds.Top);
end
else
begin
TextBounds := Rect(0, 0, 0, 0);
TextSize := Point(0,0);
end;
{ If the layout has the glyph on the right or the left, then both the
text and the glyph are centered vertically. If the glyph is on the top
or the bottom, then both the text and the glyph are centered horizontally.}
if Layout in [blImageLeft, blImageRight] then
begin
GlyphPos.Y := (ClientSize.Y - GlyphSize.Y + 1) div 2;
TextPos.Y := (ClientSize.Y - TextSize.Y + 1) div 2;
end
else
begin
GlyphPos.X := (ClientSize.X - GlyphSize.X + 1) div 2;
TextPos.X := (ClientSize.X - TextSize.X + 1) div 2;
end;
{ if there is no text or no bitmap, then Spacing is irrelevant }
if (TextSize.X = 0) or (GlyphSize.X = 0) then
Spacing := 0;
{ adjust Margin and Spacing }
if Margin = -1 then
begin
if Spacing = -1 then
begin
TotalSize := Point(GlyphSize.X + TextSize.X, GlyphSize.Y + TextSize.Y);
if Layout in [blImageLeft, blImageRight] then
Margin := (ClientSize.X - TotalSize.X) div 3
else
Margin := (ClientSize.Y - TotalSize.Y) div 3;
Spacing := Margin;
end
else
begin
TotalSize := Point(GlyphSize.X + Spacing + TextSize.X, GlyphSize.Y +
Spacing + TextSize.Y);
if Layout in [blImageLeft, blImageRight] then
Margin := (ClientSize.X - TotalSize.X + 1) div 2
else
Margin := (ClientSize.Y - TotalSize.Y + 1) div 2;
end;
end
else
begin
if Spacing = -1 then
begin
TotalSize := Point(ClientSize.X - (Margin + GlyphSize.X), ClientSize.Y -
(Margin + GlyphSize.Y));
if Layout in [blImageLeft, blImageRight] then
Spacing := (TotalSize.X - TextSize.X) div 2
else
Spacing := (TotalSize.Y - TextSize.Y) div 2;
end;
end;
case Layout of
blImageLeft:
begin
GlyphPos.X := Margin;
TextPos.X := GlyphPos.X + GlyphSize.X + Spacing;
end;
blImageRight:
begin
GlyphPos.X := ClientSize.X - Margin - GlyphSize.X;
TextPos.X := GlyphPos.X - Spacing - TextSize.X;
end;
blImageTop:
begin
GlyphPos.Y := Margin;
TextPos.Y := GlyphPos.Y + GlyphSize.Y + Spacing;
end;
blImageBottom:
begin
GlyphPos.Y := ClientSize.Y - Margin - GlyphSize.Y;
TextPos.Y := GlyphPos.Y - Spacing - TextSize.Y;
end;
end;
{ fixup the result variables }
with GlyphPos do
begin
Inc(X, Client.Left + Offset.X);
Inc(Y, Client.Top + Offset.Y);
end;
{ Themed text is not shifted, but gets a different color. }
if ThemeServices.ThemesEnabled then
OffsetRect(TextBounds, TextPos.X + Client.Left, TextPos.Y + Client.Top)
else
OffsetRect(TextBounds, TextPos.X + Client.Left + Offset.X, TextPos.Y + Client.Top + Offset.Y);
end;
function TnSpeedButton.Draw(Canvas: TCanvas; const Client: TRect;
const Offset: TPoint; const Caption: string; Layout: TButtonLayout;
Margin, Spacing: Integer; State: TButtonState; Transparent, SetGrayScaleAndOpacity: Boolean;
BiDiFlags: LongInt): TRect;
var
GlyphPos: TPoint;
begin
CalcButtonLayout(Canvas, Client, Offset, Caption, Layout, Margin, Spacing, GlyphPos, Result, BiDiFlags);
if ((FImageList <> nil) and (FImageIndex >= 0) and (FImageIndex < FImageList.Count)) then
DrawButtonImgList(Canvas, GlyphPos, State, Transparent, SetGrayScaleAndOpacity)
else
DrawButtonGlyph(Canvas, GlyphPos, State, Transparent, SetGrayScaleAndOpacity);
DrawButtonText(Canvas, Caption, Result, State, BiDiFlags);
end;
{ TcSpeedButtonActionLink }
procedure TcSpeedButtonActionLink.AssignClient(AClient: TObject);
begin
inherited AssignClient(AClient);
FClient := AClient as TnSpeedButton;
end;
function TcSpeedButtonActionLink.IsCheckedLinked: Boolean;
begin
Result := inherited IsCheckedLinked and (FClient.GroupIndex <> 0) and
FClient.AllowAllUp and (FClient.Down = (Action as TCustomAction).Checked);
end;
function TcSpeedButtonActionLink.IsGroupIndexLinked: Boolean;
begin
Result := (FClient is TnSpeedButton) and
(TnSpeedButton(FClient).GroupIndex = (Action as TCustomAction).GroupIndex);
end;
procedure TcSpeedButtonActionLink.SetChecked(Value: Boolean);
begin
if IsCheckedLinked then TnSpeedButton(FClient).Down := Value;
end;
procedure TcSpeedButtonActionLink.SetGroupIndex(Value: Integer);
begin
if IsGroupIndexLinked then TnSpeedButton(FClient).GroupIndex := Value;
end;
{ TnSpeedButton }
constructor TnSpeedButton.Create(AOwner: TComponent);
var
I: TButtonState;
begin
FGlyphImgList := TImageList.Create(Self);
FOriginalOver := TBitmap.Create;
FOriginalDown := TBitmap.Create;
FOriginal := TBitmap.Create;
FOriginal.OnChange := GlyphChanged;
FTransparentColor := clOlive;
for I := Low(I) to High(I) do
FIndexs[I] := -1;
inherited Create(AOwner);
SetBounds(0, 0, 76, 26);
ControlStyle := [csCaptureMouse, csDoubleClicks];
ParentFont := True;
Color := clBtnFace;
FSpacing := 4;
FMargin := -1;
FLayout := blImageLeft;
FTransparent := True;
FEnabledGrayScale := [bsGrayScale];
FEOpacity := 50; //50% de 100 a 1
FImageChangeLink := TChangeLink.Create;
FImageChangeLink.OnChange := ImageListChange;
FImageIndex := -1;
FOverDraw := false;
FOverIndexNormal := 0;
FOverIndexDown := 1;
FOverIndexOver := 2;
FImgOvSize := false;
end;
destructor TnSpeedButton.Destroy;
begin
FGlyphImgList.Clear;
FreeAndNil(FGlyphImgList);
FOriginalOver.Free;
FOriginalDown.Free;
FOriginal.Free;
FreeAndNil(FImageChangeLink);
if Assigned(FInternalImageList) then
FreeAndNil(FInternalImageList);
inherited Destroy;
Invalidate;
end;
procedure TnSpeedButton.Paint;
const
DownStyles: array[Boolean] of Integer = (BDR_RAISEDINNER, BDR_SUNKENOUTER);
FillStyles: array[Boolean] of Integer = (BF_MIDDLE, 0);
var
PaintRect: TRect;
DrawFlags: Integer;
Offset: TPoint;
Button: TThemedButton;
ToolButton: TThemedToolBar;
Details: TThemedElementDetails;
begin
if ImgOvSize and (Glyph.Width > 0) and (Glyph.Height > 0) then
SetBounds(Left, Top, Glyph.Width, Glyph.Height);
if not Enabled then
begin
FState := bsDisabled;
FDragging := False;
end else
if FState = bsDisabled then
if FDown and (GroupIndex <> 0) then
FState := bsExclusive
else
FState := bsUp;
Canvas.Font := Self.Font;
if ThemeServices.ThemesEnabled then
begin
PerformEraseBackground(Self, Canvas.Handle);
if not Enabled then
Button := tbPushButtonDisabled
else
if FState in [bsDown, bsExclusive] then
Button := tbPushButtonPressed
else
if MouseInControl then
Button := tbPushButtonHot
else
Button := tbPushButtonNormal;
ToolButton := ttbToolbarDontCare;
if FFlat then
begin
case Button of
tbPushButtonDisabled : Toolbutton := ttbButtonDisabled;
tbPushButtonPressed : Toolbutton := ttbButtonPressed;
tbPushButtonHot : Toolbutton := ttbButtonHot;
tbPushButtonNormal : Toolbutton := ttbButtonNormal;
end;
end;
PaintRect := ClientRect;
if ToolButton = ttbToolbarDontCare then
begin
if not FImgOvNoFlat then
begin
Details := ThemeServices.GetElementDetails(Button);
ThemeServices.DrawElement(Canvas.Handle, Details, PaintRect);
PaintRect := ThemeServices.ContentRect(Canvas.Handle, Details, PaintRect);
end;
end
else
begin
if not FImgOvNoFlat then
begin
Details := ThemeServices.GetElementDetails(ToolButton);
ThemeServices.DrawElement(Canvas.Handle, Details, PaintRect);
PaintRect := ThemeServices.ContentRect(Canvas.Handle, Details, PaintRect);
end;
end;
if Button = tbPushButtonPressed then
begin
// A pressed speed button has a white text. This applies however only to flat buttons.
if ToolButton <> ttbToolbarDontCare then
Canvas.Font.Color := clHighlightText;
Offset := Point(0, 1);
end
else
Offset := Point(0, 0);
if ((FImageList <> nil) and (FImageIndex >= 0) and (FImageIndex < FImageList.Count)) then
begin
Draw(Canvas, PaintRect, Offset, Caption, FLayout, FMargin, FSpacing, FState, Transparent, Enabled, DrawTextBiDiModeFlags(0));
end else
Draw(Canvas, PaintRect, Offset, Caption, FLayout, FMargin, FSpacing, FState, Transparent, Enabled, DrawTextBiDiModeFlags(0));
end else //sen theme
begin
PaintRect := Rect(0, 0, Width, Height);
if not FFlat then
begin
if not FImgOvNoFlat then
begin
DrawFlags := DFCS_BUTTONPUSH or DFCS_ADJUSTRECT;
if FState in [bsDown, bsExclusive] then
DrawFlags := DrawFlags or DFCS_PUSHED;
DrawFrameControl(Canvas.Handle, PaintRect, DFC_BUTTON, DrawFlags);
end;
end else //com FFlat
begin
if (FState in [bsDown, bsExclusive]) or (FMouseInControl and (FState <> bsDisabled)) or (csDesigning in ComponentState) then
if not FImgOvNoFlat then
DrawEdge(Canvas.Handle, PaintRect, DownStyles[FState in [bsDown, bsExclusive]], FillStyles[Transparent] or BF_RECT)
else
if not Transparent then
begin
Canvas.Brush.Color := Color;
Canvas.FillRect(PaintRect);
end;
InflateRect(PaintRect, -1, -1);
end;
if FState in [bsDown, bsExclusive] then
begin
if (FState = bsExclusive) and (not FFlat or not FMouseInControl) then
begin
if not FOverDraw then
begin
Canvas.Brush.Bitmap := AllocPatternBitmap(clBtnFace, clBtnHighlight);
Canvas.FillRect(PaintRect);
end;
end;
Offset.X := 1;
Offset.Y := 1;
end
else
begin
Offset.X := 0;
Offset.Y := 0;
end;
if ((FImageList <> nil) and (FImageIndex >= 0) and (FImageIndex < FImageList.Count)) then
begin
if (FImageIndex > -1) and (FImageIndex < FImageList.Count) then
begin
Glyph.Width := FImageList.Width; Glyph.Height := FImageList.Height;
end;
Draw(Canvas, PaintRect, Offset, Caption, FLayout, FMargin, FSpacing, FState, Transparent, Enabled, DrawTextBiDiModeFlags(0));
end else
Draw(Canvas, PaintRect, Offset, Caption, FLayout, FMargin, FSpacing, FState, Transparent, Enabled, DrawTextBiDiModeFlags(0));
end;
end;
procedure TnSpeedButton.UpdateTracking;
var
P: TPoint;
begin
if FFlat then
begin
if Enabled then
begin
GetCursorPos(P);
FMouseInControl := not (FindDragTarget(P, True) = Self);
if FMouseInControl then
Perform(CM_MOUSELEAVE, 0, 0)
else
Perform(CM_MOUSEENTER, 0, 0);
end;
end;
end;
procedure TnSpeedButton.Loaded;
var
State: TButtonState;
begin
inherited Loaded;
if Enabled then
State := bsUp
else
State := bsDisabled;
CreateButtonGlyph2(State);
end;
procedure TnSpeedButton.MouseDown(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer);
begin
inherited MouseDown(Button, Shift, X, Y);
if (Button = mbLeft) and Enabled then
begin
if not FDown then
begin
FState := bsDown;
Invalidate;
end;
FDragging := True;
end;
end;
procedure TnSpeedButton.MouseMove(Shift: TShiftState; X, Y: Integer);
var
NewState: TButtonState;
begin
inherited MouseMove(Shift, X, Y);
if FDragging then
begin
if not FDown then NewState := bsUp
else NewState := bsExclusive;
if (X >= 0) and (X < ClientWidth) and (Y >= 0) and (Y <= ClientHeight) then
if FDown then NewState := bsExclusive else NewState := bsDown;
if NewState <> FState then
begin
FState := NewState;
Invalidate;
end;
end
else if not FMouseInControl then
UpdateTracking;
end;
procedure TnSpeedButton.MouseUp(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer);
var
DoClick: Boolean;
begin
inherited MouseUp(Button, Shift, X, Y);
if FDragging then
begin
FDragging := False;
DoClick := (X >= 0) and (X < ClientWidth) and (Y >= 0) and (Y <= ClientHeight);
if FGroupIndex = 0 then
begin
{ Redraw face in-case mouse is captured }
FState := bsUp;
FMouseInControl := False;
if DoClick and not (FState in [bsExclusive, bsDown]) then
Invalidate;
end
else
if DoClick then
begin
SetDown(not FDown);
if FDown then Repaint;
end
else
begin
if FDown then FState := bsExclusive;
Repaint;
end;
if DoClick then Click;
UpdateTracking;
end;
end;
procedure TnSpeedButton.Click;
begin
inherited Click;
end;
function TnSpeedButton.GetPalette: HPALETTE;
begin
Result := Glyph.Palette;
end;
function TnSpeedButton.GetActionLinkClass: TControlActionLinkClass;
begin
Result := TcSpeedButtonActionLink;
end;
procedure TnSpeedButton.SetGlyph(Value: TBitmap);
begin
Invalidate;
FOriginal.Assign(Value);
if (Value <> nil) and (Value.Height > 0) then
FTransparentColor := Value.TransparentColor;
end;
procedure TnSpeedButton.SetGlyphOver(const Value: TBitmap);
begin
Invalidate;
FOriginalOver.Assign(Value);
if (Value <> nil) and (Value.Height > 0) then
FTransparentColor := Value.TransparentColor;
end;
procedure TnSpeedButton.SetGlyphDown(const Value: TBitmap);
begin
Invalidate;
FOriginalDown.Assign(Value);
if (Value <> nil) and (Value.Height > 0) then
FTransparentColor := Value.TransparentColor;
end;
procedure TnSpeedButton.GlyphChanged(Sender: TObject);
begin
if (Sender = FOriginal) or (Sender = FOriginalDown) or (Sender = FOriginalOver) then
begin
FTransparentColor := FOriginal.TransparentColor or FOriginalDown.TransparentColor or FOriginalOver.TransparentColor;
Invalidate;
if Assigned(FOnChange) then FOnChange(Self);
end;
Invalidate;
end;
procedure TnSpeedButton.UpdateExclusive;
var
Msg: TMessage;
begin
if (FGroupIndex <> 0) and (Parent <> nil) then
begin
Msg.Msg := CM_BUTTONPRESSED;
Msg.WParam := FGroupIndex;
Msg.LParam := Longint(Self);
Msg.Result := 0;
Parent.Broadcast(Msg);
end;
end;
procedure TnSpeedButton.SetDown(Value: Boolean);
begin
if FGroupIndex = 0 then Value := False;
if Value <> FDown then
begin
if FDown and (not FAllowAllUp) then Exit;
FDown := Value;
if Value then
begin
if FState = bsUp then Invalidate;
FState := bsExclusive
end
else
begin
FState := bsUp;
Repaint;
end;
if Value then UpdateExclusive;
end;
end;
procedure TnSpeedButton.SetFlat(Value: Boolean);
begin
if Value <> FFlat then
begin
FFlat := Value;
Invalidate;
end;
end;
procedure TnSpeedButton.SetGroupIndex(Value: Integer);
begin
if FGroupIndex <> Value then
begin
FGroupIndex := Value;
UpdateExclusive;
end;
end;
procedure TnSpeedButton.SetLayout(Value: TButtonLayout);
begin
if FLayout <> Value then
begin
FLayout := Value;
Invalidate;
end;
end;
procedure TnSpeedButton.SetMargin(Value: Integer);
begin
if (Value <> FMargin) and (Value >= -1) then
begin
FMargin := Value;
Invalidate;
end;
end;
procedure TnSpeedButton.SetSpacing(Value: Integer);
begin
if Value <> FSpacing then
begin
FSpacing := Value;
Invalidate;
end;
end;
procedure TnSpeedButton.SetTransparent(Value: Boolean);
begin
if Value <> FTransparent then
begin
FTransparent := Value;
if Value then
ControlStyle := ControlStyle - [csOpaque] else
ControlStyle := ControlStyle + [csOpaque];
Invalidate;
end;
end;
procedure TnSpeedButton.SetAllowAllUp(Value: Boolean);
begin
if FAllowAllUp <> Value then
begin
FAllowAllUp := Value;
UpdateExclusive;
end;
end;
procedure TnSpeedButton.WMLButtonDblClk(var Message: TWMLButtonDown);
begin
inherited;
if FDown then DblClick;
end;
procedure TnSpeedButton.CMEnabledChanged(var Message: TMessage);
const
NewState: array[Boolean] of TButtonState = (bsDisabled, bsUp);
begin
CreateButtonGlyph2(NewState[Enabled]);
UpdateTracking;
Repaint;
end;
procedure TnSpeedButton.CMButtonPressed(var Message: TMessage);
var
Sender: TnSpeedButton;
begin
if Message.WParam = FGroupIndex then
begin
Sender := TnSpeedButton(Message.LParam);
if Sender <> Self then
begin
if Sender.Down and FDown then
begin
FDown := False;
FState := bsUp;
if (Action is TCustomAction) then
TCustomAction(Action).Checked := False;
Invalidate;
end;
FAllowAllUp := Sender.AllowAllUp;
end;
end;
end;
procedure TnSpeedButton.CMDialogChar(var Message: TCMDialogChar);
begin
with Message do
if IsAccel(CharCode, Caption) and Enabled and Visible and
(Parent <> nil) and Parent.Showing then
begin
Click;
Result := 1;
end else
inherited;
end;
procedure TnSpeedButton.CMFontChanged(var Message: TMessage);
begin
Invalidate;
end;
procedure TnSpeedButton.CMTextChanged(var Message: TMessage);
begin
Invalidate;
end;
procedure TnSpeedButton.CMSysColorChange(var Message: TMessage);
begin
Invalidate;
end;
procedure TnSpeedButton.CMMouseEnter(var Message: TMessage);
var
NeedRepaint, OnOffThemeServices: Boolean;
begin
inherited;
if Assigned(FOnMouseEnter) then FOnMouseEnter(Self);
{ Don't draw a border if DragMode <> dmAutomatic since this button is meant to
be used as a dock client. }
if FOverDraw then
OnOffThemeServices := FOverDraw
else
OnOffThemeServices := ThemeServices.ThemesEnabled;
NeedRepaint := FFlat and not FMouseInControl and Enabled and (DragMode <> dmAutomatic) and (GetCapture = 0);
{ Windows XP introduced hot states also for non-flat buttons. }
if (NeedRepaint or OnOffThemeServices) and not (csDesigning in ComponentState) then
begin
FMouseInControl := True;
if Enabled then
Repaint;
end;
end;
procedure TnSpeedButton.CMMouseLeave(var Message: TMessage);
var
NeedRepaint, OnOffThemeServices: Boolean;
begin
inherited;
if Assigned(FOnMouseLeave) then FOnMouseLeave(Self);
if FOverDraw then
OnOffThemeServices := FOverDraw
else
OnOffThemeServices := ThemeServices.ThemesEnabled;
NeedRepaint := FFlat and FMouseInControl and Enabled and not FDragging;
{ Windows XP introduced hot states also for non-flat buttons. }
if NeedRepaint or OnOffThemeServices then
begin
//if FOverDraw then
FMouseInControl := False;
if Enabled then
Repaint;
end;
end;
procedure TnSpeedButton.ActionChange(Sender: TObject; CheckDefaults: Boolean);
procedure CopyImage(ImageList: TCustomImageList; Index: Integer);
begin
with Glyph do
begin
Width := ImageList.Width;
Height := ImageList.Height;
Canvas.Brush.Color := clFuchsia;//! for lack of a better color
Canvas.FillRect(Rect(0,0, Width, Height));
ImageList.Draw(Canvas, 0, 0, Index);
end;
end;
begin
inherited ActionChange(Sender, CheckDefaults);
if Sender is TCustomAction then
with TCustomAction(Sender) do
begin
if CheckDefaults or (Self.GroupIndex = 0) then
Self.GroupIndex := GroupIndex;
{ Copy image from action's imagelist }
if (Glyph.Empty) and (ActionList <> nil) and (ActionList.Images <> nil) and
(ImageIndex >= 0) and (ImageIndex < ActionList.Images.Count) then
CopyImage(ActionList.Images, ImageIndex);
end;
end;
procedure TnSpeedButton.AlphaTransBitmap(Canvas: TCanvas; const PsW, PsH: Integer;
const SrcBmp: TBitmap; Enabled_GScale_Opacity: Boolean);
var
TmpDstBmp: TBitmap;
w,h : Integer;
aR1 : TRect;
//===Opacidade bitmap e tom cinza Bitmap============================
function nGrayScaleOpacity(Bmp: TBitmap): TBitmap;
var
ScanL, SA : PRGBAArray;
x, Y, w, h : integer;
begin
if (FEnabledGrayScale = [bsGrayScale]) or (FEnabledGrayScale = [bsGrayScale, bsOpacity]) then
begin
h := Bmp.Height - 1;
w := Bmp.Width - 1;
for Y := 0 to h do begin
SA := Bmp.scanline[Y];
for x := 0 to w do begin
SA[x].R := (SA[x].R + SA[x].G + SA[x].B) div 3;
SA[x].G := SA[x].R;
SA[x].B := SA[x].R;
end;
end;
end;
if (FEnabledGrayScale = [bsOpacity]) or (FEnabledGrayScale = [bsOpacity, bsGrayScale]) then
begin
for Y := 0 to Bmp.Height - 1 do
begin
ScanL := Bmp.ScanLine[Y];
for X := 0 to Bmp.Width - 1 do
ScanL[X].A := (ScanL[X].A * FEOpacity) div 100;
end;
end;
Result := Bmp;
end;
//====================================================================
//Criar Bitmap Virtual 32 Btis
function CreateBmpV32(const Width, Height : integer) : TBitmap;
begin
Result := TBitmap.Create;
Result.PixelFormat := pf32bit;
Result.HandleType := bmDIB;
Result.Width := Width;
Result.Height := Height;
end;
// converte canal alpha!
procedure ConvertAlphaChannelBmp32b(R1, R2 : TRect; const BmpDst, BmpSrc : TBitmap);
var
S1 : PRGBAArray;
S2 : PRGBAArray;
X, Y, h, w, sX1, sX2: Integer;
Col_ : TnColor_;
begin
if BmpSrc = nil then Exit;
BmpSrc.PixelFormat := pf32Bit;
h := Min((R1.Bottom - R1.Top),(R2.Bottom - R2.Top));
h := Min(h, BmpDst.Height - R1.Top);
h := Min(h, BmpSrc.Height - R2.Top) - 1;
if h < 0 then Exit;
w := Min((R1.Right - R1.Left), (R2.Right - R2.Left));
w := Min(w, BmpDst.Width - R1.Left);
w := Min(w, BmpSrc.Width - R2.Left);
if w < 0 then Exit;
w := Min(w, BmpDst.Width - R1.Left);
w := Min(w, BmpSrc.Width - R2.Left) - 1;
for Y := 0 to h do
begin
S1 := BmpDst.ScanLine[R1.Top + Y];
S2 := BmpSrc.ScanLine[R2.Top + Y];
sX1 := R1.Left;
sX2 := R2.Left;
for X := 0 to w do
begin
Col_ := S2[sX2];
if Col_.C <> clFuchsia then
begin
S1[sX1].R := (((S2[sX2].R - S1[sX1].R) * S2[sX2].A + S1[sX1].R shl 8) shr 8) and MaxByte;
S1[sX1].G := (((S2[sX2].G - S1[sX1].G) * S2[sX2].A + S1[sX1].G shl 8) shr 8) and MaxByte;
S1[sX1].B := (((S2[sX2].B - S1[sX1].B) * S2[sX2].A + S1[sX1].B shl 8) shr 8) and MaxByte;
end;
inc(sX1);
inc(sX2);
end;
end;
end;
//Inicio da Funcção no Bitmap
begin
aR1:= Rect(0, 0, SrcBmp.Width, SrcBmp.Height);
w := aR1.Right - aR1.Left;
h := aR1.Bottom - aR1.Top;
TmpDstBmp := CreateBmpV32(w, h);
if not Enabled_GScale_Opacity then
nGrayScaleOpacity(SrcBmp);
if not ((w = SrcBmp.Width) or (h = SrcBmp.Height)) then Exit;
try
SrcBmp.PixelFormat := pf32bit;
SrcBmp.Width := w;
SrcBmp.Height := h;
BitBlt(TmpDstBmp.Canvas.Handle, 0, 0, w, h, Canvas.Handle, PsW, PsH, SRCCOPY);
ConvertAlphaChannelBmp32b(Classes.Rect(0, 0, w, h), Classes.Rect(0, 0, w, h), TmpDstBmp, SrcBmp);
BitBlt(Canvas.Handle, PsW, PsH, TmpDstBmp.Width, TmpDstBmp.Height, TmpDstBmp.Canvas.Handle, 0, 0, SRCCOPY);
finally
FreeAndNil(TmpDstBmp);
end;
end;
procedure TnSpeedButton.SetEnabledGrayScale(const Value: TEnabled_IGs);
begin
if not Enabled then begin
if EnabledGrayScale <> Value then
FEnabledGrayScale := Value;
Invalidate;
end;
end;
procedure TnSpeedButton.SetEnabledOpacity(const Value: integer);
begin
if not Enabled then
begin
if FEOpacity <> Value then
begin
if Value < 0 then
FEOpacity := 0
else
if Value > 100 then
FEOpacity := 100
else
FEOpacity := Value;
Invalidate;
end;
end;
end;
procedure TnSpeedButton.SetImageIndex(const Value: TImageIndex);
begin
if (FImageIndex <> Value) then
begin
FImageIndex := Value;
if FImageIndex = -1 then
begin
FOriginal.Assign(nil);
Glyph.Assign(nil);
end;
Invalidate;
end;
end;
procedure TnSpeedButton.SetImages(const Value: TCustomImageList);
begin
if ImageList <> Value then
begin
if ImageList <> nil then ImageList.UnRegisterChanges(FImageChangeLink);
FImageList := Value;
if FImageList <> nil then
begin
ImageList.RegisterChanges(FImageChangeLink);
ImageList.FreeNotification(Self);
end;
end;
end;
procedure TnSpeedButton.ImageListChange(Sender: TObject);
begin
Invalidate;
end;
procedure TnSpeedButton.DrawButtonImgList(Canvas: TCanvas; const GlyphPos: TPoint;
State: TButtonState; Transparent, SetGrayScaleAndOpacity: Boolean);
var
Bmp : TBitmap;
MakeColor : TColor;
procedure PreparingBitmap(IndexToInsert: Integer; ImageListToInsert: TCustomImageList);
begin
Bmp.Width := ImageListToInsert.Width;
Bmp.Height := ImageListToInsert.Height;
Bmp.PixelFormat := pf32bit;
if ImageListToInsert.BkColor <> clNone then
MakeColor := ImageListToInsert.BkColor
else
MakeColor := clFuchsia;
Bmp.Canvas.Brush.Color := MakeColor;
Bmp.Canvas.FillRect(Rect(0, 0, Bmp.Width, Bmp.Height));
ImageListToInsert.GetBitmap(IndexToInsert, Bmp);
end;
begin
bmp := TBitmap.Create;
if FOverDraw then
begin
if (FState = bsDown) or (Down) then
PreparingBitmap(ImgOvIdxDown, FImageList)
else
if MouseInControl then
PreparingBitmap(ImgOvIdxOver, FImageList)
else
PreparingBitmap(ImgOvIdxNormal, FImageList)
end else
PreparingBitmap(FImageIndex, FImageList);
try
AlphaTransBitmap(Canvas, GlyphPos.X, GlyphPos.Y, Bmp, SetGrayScaleAndOpacity);
finally
FreeAndNil(Bmp);
end;
end;
procedure TnSpeedButton.SetOverDraw(const Value: Boolean);
begin
if FOverDraw <> Value then
begin
FOverDraw := Value;
if not FFlat then
FFlat := true;
Flat := FFlat;
Invalidate;
end;
end;
procedure TnSpeedButton.SetImgOvSize(const Value: Boolean);
begin
if FImgOvSize <> Value then
begin
FImgOvSize := Value;
if ImgOvSize and (Glyph.Width > 0) and (Glyph.Height > 0) then
SetBounds(Left, Top, Glyph.Width, Glyph.Height);
Invalidate;
end;
end;
procedure TnSpeedButton.SetImgOvNoFlat(const Value: Boolean);
begin
if FImgOvNoFlat <> Value then
begin
FImgOvNoFlat := Value;
Invalidate;
end;
end;
initialization
{$IFDEF Pnggraphics}
// TPicture.RegisterFileFormat('png','Portable network graphics (TPNGGraphic)', TPNGGraphic);
{$ENDIF}
finalization
{$IFDEF Pnggraphics}
//TPicture.UnregisterGraphicClass(TPNGGraphic);
{$ENDIF}
end.
Cgm2k7 2013
Curtidas 0