自定义组件-支持PNG图片的多态GraphicButton
Posted 黑暗煎饼果子
tags:
篇首语:本文由小常识网(cha138.com)小编为大家整理,主要介绍了自定义组件-支持PNG图片的多态GraphicButton相关的知识,希望对你有一定的参考价值。
按钮功能使用TButton也可以解决, 但是TButton是会获得焦点的, 很多时候我们要求按钮不获得焦点, 而Speedbutton又不支持PNG图片
所以按照TSpeedbutton的代码, 重新封装了一个:
unit HSImageButton; // *************************************************************************** // // 支持PNG的Graphicbutton // // 版本: 1.0 // 作者: 刘志林 // 修改日期: 2016-07-12 // QQ: 17948876 // E-mail: lzl_17948876@hotmail.com // 博客: http://www.cnblogs.com/lzl_17948876/ // // !!! 若有修改,请通知作者,谢谢合作 !!! // // --------------------------------------------------------------------------- // // 说明: // 1.通过绑定ImageList来显示图标 // 2.通过Imagelist对PNG的支持来显示PNG图标 // 3.支持4种状态切换 (Normal/Hot/Pressed/Disabled) // 4.支持图片位置排列 (ImageAlignment) // 5.支持SpeedButton的Group模式 // 6.版本兼容至D2010 // // *************************************************************************** interface uses System.Classes, System.SysUtils, System.Types, {$IF RTLVersion >= 29} System.ImageList, {$ENDIF} Winapi.Messages, Winapi.Windows, Vcl.Controls, Vcl.StdCtrls, Vcl.Buttons, Vcl.Graphics, Vcl.Forms, Vcl.Themes, Vcl.ImgList, Vcl.ActnList; type THSImageButton = class; THSImageButtonActionLink = class(TControlActionLink) protected FClient: THSImageButton; procedure AssignClient(AClient: TObject); override; function IsCheckedLinked: Boolean; override; function IsGroupIndexLinked: Boolean; override; function IsImageIndexLinked: Boolean; override; procedure SetGroupIndex(Value: Integer); override; procedure SetChecked(Value: Boolean); override; procedure SetImageIndex(Value: Integer); override; public constructor Create(AClient: TObject); override; end; THSImageButtonActionLinkClass = class of THSImageButtonActionLink; THSImageButton = class(TGraphicControl) private FGroupIndex: Integer; FDown: Boolean; FDragging: Boolean; FAllowAllUp: Boolean; FSpacing: Integer; FTransparent: Boolean; FMargin: Integer; FFlat: Boolean; FMouseInControl: Boolean; FImageAlignment: TImageAlignment; FImages: TCustomImageList; FImageMargins: TImageMargins; FImageIndex: TImageIndex; FPressedImageIndex: TImageIndex; FDisabledImageIndex: TImageIndex; FHotImageIndex: TImageIndex; FImageChangeLink: TChangeLink; procedure GlyphChanged(Sender: TObject); procedure UpdateExclusive; procedure SetDown(Value: Boolean); procedure SetFlat(Value: Boolean); procedure SetAllowAllUp(Value: Boolean); procedure SetGroupIndex(Value: Integer); procedure SetSpacing(Value: Integer); procedure SetTransparent(Value: Boolean); procedure SetMargin(Value: Integer); procedure UpdateTracking; procedure WMLButtonDblClk(var Message: TWMLButtonDblClk); message WM_LBUTTONDBLCLK; procedure CMEnabledChanged(var Message: TMessage); message CM_ENABLEDCHANGED; 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 CMMouseEnter(var Message: TMessage); message CM_MOUSEENTER; procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE; procedure CMButtonPressed(var Message: TMessage); message CM_BUTTONPRESSED; procedure SetImageAlignment(const Value: TImageAlignment); procedure SetImageIndex(const Value: TImageIndex); procedure SetImageMargins(const Value: TImageMargins); procedure SetImages(const Value: TCustomImageList); procedure SetDisabledImageIndex(const Value: TImageIndex); procedure SetHotImageIndex(const Value: TImageIndex); procedure SetPressedImageIndex(const Value: TImageIndex); protected FState: TButtonState; procedure Notification(AComponent: TComponent; Operation: TOperation); override; procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; function GetActionLinkClass: TControlActionLinkClass; 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; procedure ImageMarginsChange(Sender: TObject); procedure ImageListChange(Sender: TObject); public constructor Create(AOwner: TComponent); override; destructor Destroy; override; procedure Click; override; published property Action; property Align; 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 Images: TCustomImageList read FImages write SetImages; property ImageAlignment: TImageAlignment read FImageAlignment write SetImageAlignment default iaLeft; property ImageIndex: TImageIndex read FImageIndex write SetImageIndex default -1; property HotImageIndex: TImageIndex read FHotImageIndex write SetHotImageIndex default -1; property PressedImageIndex: TImageIndex read FPressedImageIndex write SetPressedImageIndex default -1; property DisabledImageIndex: TImageIndex read FDisabledImageIndex write SetDisabledImageIndex default -1; property ImageMargins: TImageMargins read FImageMargins write SetImageMargins; 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 StyleElements; property OnClick; property OnDblClick; property OnMouseActivate; property OnMouseDown; property OnMouseEnter; property OnMouseLeave; property OnMouseMove; property OnMouseUp; end; implementation { THSImageButton } constructor THSImageButton.Create(AOwner: TComponent); begin inherited Create(AOwner); SetBounds(0, 0, 23, 22); ControlStyle := [csCaptureMouse, csDoubleClicks]; ParentFont := True; Color := clBtnFace; FSpacing := 4; FMargin := -1; FTransparent := True; FImageIndex := -1; FDisabledImageIndex := -1; FPressedImageIndex := -1; FHotImageIndex := -1; FImageMargins := TImageMargins.Create; FImageMargins.OnChange := ImageMarginsChange; FImageChangeLink := TChangeLink.Create; FImageChangeLink.OnChange := ImageListChange; end; destructor THSImageButton.Destroy; begin FreeAndNil(FImageChangeLink); FreeAndNil(FImageMargins); inherited Destroy; end; const DownStyles: array[Boolean] of Integer = (BDR_RAISEDINNER, BDR_SUNKENOUTER); FillStyles: array[Boolean] of Integer = (BF_MIDDLE, 0); procedure THSImageButton.Paint; function DoGlassPaint: Boolean; var nLParent: TWinControl; begin Result := csGlassPaint in ControlState; if Result then begin nLParent := Parent; while (nLParent <> nil) and not nLParent.DoubleBuffered do nLParent := nLParent.Parent; Result := (nLParent = nil) or not nLParent.DoubleBuffered or (nLParent is TCustomForm); end; end; var nPaintRect, nTextRect: TRect; nDrawFlags, nImageIndex: Integer; nOffset, nTmpPoint: TPoint; nLGlassPaint: Boolean; nTMButton: TThemedButton; nTMToolBar: TThemedToolBar; nDetails: TThemedElementDetails; nLStyle: TCustomStyleServices; nLColor: TColor; nLFormats: TTextFormat; nTextFlg: DWORD; {$IF RTLVersion >= 27} nDefGrayscaleFactor: Byte; {$ENDIF} begin {Copy As TSpeedButton.Paint} 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; Canvas.Brush.Style := bsClear; if ThemeControl(Self) then begin nLGlassPaint := DoGlassPaint; if not nLGlassPaint then if Transparent then StyleServices.DrawParentBackground(0, Canvas.Handle, nil, True) else PerformEraseBackground(Self, Canvas.Handle) else FillRect(Canvas.Handle, ClientRect, GetStockObject(BLACK_BRUSH)); if not Enabled then nTMButton := tbPushButtonDisabled else if FState in [bsDown, bsExclusive] then nTMButton := tbPushButtonPressed else if MouseInControl then nTMButton := tbPushButtonHot else nTMButton := tbPushButtonNormal; nTMToolBar := ttbToolbarDontCare; if FFlat or TStyleManager.IsCustomStyleActive then begin case nTMButton of tbPushButtonDisabled: nTMToolBar := ttbButtonDisabled; tbPushButtonPressed: nTMToolBar := ttbButtonPressed; tbPushButtonHot: nTMToolBar := ttbButtonHot; tbPushButtonNormal: nTMToolBar := ttbButtonNormal; end; end; nPaintRect := ClientRect; if nTMToolBar = ttbToolbarDontCare then begin nDetails := StyleServices.GetElementDetails(nTMButton); StyleServices.DrawElement(Canvas.Handle, nDetails, nPaintRect); StyleServices.GetElementContentRect(Canvas.Handle, nDetails, nPaintRect, nPaintRect); end else begin nDetails := StyleServices.GetElementDetails(nTMToolBar); if not TStyleManager.IsCustomStyleActive then begin StyleServices.DrawElement(Canvas.Handle, nDetails, nPaintRect); // Windows theme services doesn\'t paint disabled toolbuttons // with grayed text (as it appears in an actual toolbar). To workaround, // retrieve nDetails for a disabled nTMButton for drawing the caption. if (nTMToolBar = ttbButtonDisabled) then nDetails := StyleServices.GetElementDetails(nTMButton); end else begin // Special case for flat speedbuttons with custom styles. The assumptions // made about the look of ToolBar buttons may not apply, so only paint // the hot and pressed states , leaving normal/disabled to appear flat. if not FFlat or ((nTMButton = tbPushButtonPressed) or (nTMButton = tbPushButtonHot)) then StyleServices.DrawElement(Canvas.Handle, nDetails, nPaintRect); end; StyleServices.GetElementContentRect(Canvas.Handle, nDetails, nPaintRect, nPaintRect); end; nOffset := Point(0, 0); if nTMButton = tbPushButtonPressed then begin // A pressed "flat" speed nTMButton has white text in XP, but the Themes // API won\'t render it as such, so we need to hack it. if (nTMToolBar <> ttbToolbarDontCare) and not CheckWin32Version(6) then Canvas.Font.Color := clHighlightText else if FFlat then nOffset := Point(1, 0); end; end else begin nPaintRect := Rect(1, 1, Width - 1, Height - 1); if not FFlat then begin nDrawFlags := DFCS_BUTTONPUSH or DFCS_ADJUSTRECT; if FState in [bsDown, bsExclusive] then nDrawFlags := nDrawFlags or DFCS_PUSHED; DrawFrameControl(Canvas.Handle, nPaintRect, DFC_BUTTON, nDrawFlags); end else begin if (FState in [bsDown, bsExclusive]) or (FMouseInControl and (FState <> bsDisabled)) or (csDesigning in ComponentState) then DrawEdge(Canvas.Handle, nPaintRect, DownStyles[FState in [bsDown, bsExclusive]], FillStyles[Transparent] or BF_RECT) else if not Transparent then begin Canvas.Brush.Color := Color; Canvas.FillRect(nPaintRect); end; InflateRect(nPaintRect, -1, -1); end; if FState in [bsDown, bsExclusive] then begin if (FState = bsExclusive) and (not FFlat or not FMouseInControl) then begin Canvas.Brush.Bitmap := AllocPatternBitmap(clBtnFace, clBtnHighlight); Canvas.FillRect(nPaintRect); end; nOffset.X := 1; nOffset.Y := 1; end else begin nOffset.X := 0; nOffset.Y := 0; end; nLStyle := StyleServices; end; nTextRect := ClientRect; nPaintRect := ClientRect; nPaintRect := Rect(nPaintRect.Left + FImageMargins.Left + 1, nPaintRect.Top + FImageMargins.Top + 1, nPaintRect.Right - FImageMargins.Right - 1, nPaintRect.Bottom - FImageMargins.Bottom - 1); if Images <> nil then begin {$IF RTLVersion >= 27} nDefGrayscaleFactor := Images.GrayscaleFactor; Images.GrayscaleFactor := $FF; {$ENDIF} nTmpPoint := nPaintRect.CenterPoint; case FImageAlignment of iaLeft: begin nTextRect.Left := nPaintRect.Left + Images.Width; nTmpPoint := Point(nPaintRect.Left, nPaintRect.Top + (nPaintRect.Height - Images.Height) div 2); end; iaRight: begin nTextRect.Right := nPaintRect.Right - Images.Width; nTmpPoint := Point(nTextRect.Right, nPaintRect.Top + (nPaintRect.Height - Images.Height) div 2); end; iaTop: begin nTextRect.Top := nPaintRect.Top + Images.Height; nTmpPoint := Point(nPaintRect.Left + (nPaintRect.Width - Images.Width) div 2, nPaintRect.Top); end; iaBottom: begin nTextRect.Bottom := nPaintRect.Bottom - Images.Height; nTmpPoint := Point(nPaintRect.Left + (nPaintRect.Width - Images.Width) div 2, nTextRect.Bottom); end; iaCenter: begin nTmpPoint := Point(nPaintRect.Left + (nPaintRect.Width - Images.Width) div 2, nPaintRect.Top + (nPaintRect.Height - Images.Height) div 2); end; end; if not Enabled then begin if FDisabledImageIndex > -1 then Images.Draw(Canvas, nTmpPoint.X, nTmpPoint.Y, FDisabledImageIndex, True) else Images.Draw(Canvas, nTmpPoint.X, nTmpPoint.Y, FImageIndex, False); end else begin if FState in [bsDown, bsExclusive] then nImageIndex := FPressedImageIndex else if MouseInControl then nImageIndex := FHotImageIndex else nImageIndex := FImageIndex; if nImageIndex = -1 then nImageIndex := FImageIndex; Images.Draw(Canvas, nTmpPoint.X, nTmpPoint.Y, nImageIndex, True); end; {$IF RTLVersion >= 27} Images.GrayscaleFactor := nDefGrayscaleFactor; {$ENDIF} end; nTextFlg := DT_VCENTER or DT_SINGLELINE or DT_CENTER; {Copy As TButtonGlyphc.DrawButtonText.DoDrawText} if ThemeControl(Self) then begin if (FState = bsDisabled) or (not StyleServices.IsSystemStyle and (seFont in StyleElements)) then begin if not StyleServices.GetElementColor(nDetails, ecTextColor, nLColor) or (nLColor = clNone) then nLColor := Canvas.Font.Color; end else nLColor := Canvas.Font.Color; nLFormats := TTextFormatFlags(nTextFlg); if nLGlassPaint then Include(nLFormats, tfComposited); StyleServices.DrawText(Canvas.Handle, nDetails, Text, nTextRect, nLFormats, nLColor); end else begin if FState = bsDisabled then Canvas.Font.Color := clGrayText else Canvas.Font.Color := clWindowText; Winapi.Windows.DrawText(Canvas.Handle, Text, Length(Text), nTextRect, nTextFlg); end; end; procedure THSImageButton.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 THSImageButton.Loaded; var State: TButtonState; begin inherited Loaded; if Enabled then State := bsUp else State := bsDisabled; end; procedure THSImageButton.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 THSImageButton.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 THSImageButton.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 THSImageButton.Notification(AComponent: TComponent; Operation: TOperation); begin inherited Notification(AComponent, Operation); if Operation = opRemove then begin if AComponent = FImages then begin微信小程序转发分享,封面图片自定义5:4支持iOS11UITableView左滑删除自定义 - 实现多选项并使用自定义图片