Archivado/Componentes.Terceros.SpTBXLib
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
f130fe4cb1
Componentes.Terceros.SpTBXLib/internal/2.4.4/1/Source/SpTBXControls.pas
david 03dfd8c7c1 Importación inicial 
git-svn-id: https://192.168.0.254/svn/Componentes.Terceros.SpTBXLib@4 aa3591e4-a9f2-482a-ba07-9d38a056ee4e
2010-01-19 16:32:53 +00:00

4307 lines
131 KiB
ObjectPascal
Raw Blame History

unit SpTBXControls;
{==============================================================================
Version 2.4.4
The contents of this file are subject to the SpTBXLib License; you may
not use or distribute this file except in compliance with the
SpTBXLib License.
A copy of the SpTBXLib License may be found in SpTBXLib-LICENSE.txt or at:
http://www.silverpointdevelopment.com/sptbxlib/SpTBXLib-LICENSE.htm
Alternatively, the contents of this file may be used under the terms of the
Mozilla Public License Version 1.1 (the "MPL v1.1"), in which case the provisions
of the MPL v1.1 are applicable instead of those in the SpTBXLib License.
A copy of the MPL v1.1 may be found in MPL-LICENSE.txt or at:
http://www.mozilla.org/MPL/
If you wish to allow use of your version of this file only under the terms of
the MPL v1.1 and not to allow others to use your version of this file under the
SpTBXLib License, indicate your decision by deleting the provisions
above and replace them with the notice and other provisions required by the
MPL v1.1. If you do not delete the provisions above, a recipient may use your
version of this file under either the SpTBXLib License or the MPL v1.1.
Software distributed under the License is distributed on an "AS IS" basis,
WITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for
the specific language governing rights and limitations under the License.
The initial developer of this code is Robert Lee.
Requirements:
For Delphi/C++Builder 2009 or newer:
- Jordan Russell's Toolbar 2000
http://www.jrsoftware.org
For Delphi/C++Builder 7-2007:
- Jordan Russell's Toolbar 2000
http://www.jrsoftware.org
- Troy Wolbrink's TNT Unicode Controls
http://www.tntware.com/delphicontrols/unicode/
Development notes:
- All the theme changes and adjustments are marked with '[Theme-Change]'.
- All the compatibility changes are marked with '[Backward-Compatibility]'.
History:
2 December 2009 - version 2.4.4
- Fixed TSpTBXLabel accel key handling, thanks to Costas
Stergiou for reporting this.
- Fixed incorrect hint handling on TSpTBXTextObject.
- Added Padding property to various controls, thanks to
Boris Yankov for reporting this.
13 September 2009 - version 2.4.3
- Fixed incorrect TSpTBXSpeedButton painting, when Flat is
set to true the button should be painted as a toolbar item,
thanks to Yann Papouin for reporting this.
8 May 2009 - version 2.4.2
- Added AllowAllUp property to TSpTBXSpeedButton.
15 March 2009 - version 2.4.1
- Added GlyphLayout property to TSpTBXButton/TSpTBXSpeedButton.
- Added Flat property to TSpTBXButton/TSpTBXSpeedButton.
- Fixed TSpTBXTrackBar bug, the Frequency property didn't work,
thanks to Alfred Vink for reporting this.
17 January 2009 - version 2.4
- No changes.
28 September 2008 - version 2.3.1
- Fixed incorrect TSpTBXGroupBox painting, the control was not
repainted when the font was changed, thanks to Yury Plashenkov
for reporting this.
26 September 2008 - version 2.3
- Removed LinkFont property from TSpTBXTextObject, having 2 font
properties to control the text state was a bad idea.
29 July 2008 - version 2.2
- Fixed incorrect ProgressBar painting on Windows Vista,
thanks to Arvid for reporting this.
22 June 2008 - version 2.1
- No changes.
3 May 2008 - version 2.0
- No changes.
2 April 2008 - version 1.9.5
- Improved the background painting of TSpTBXPanel.
3 February 2008 - version 1.9.4
- No changes.
19 January 2008 - version 1.9.3
- Fixed incorrect Autosizing of TSpTBXTextControl, thanks
to Alexey Naumov for reporting this.
26 December 2007 - version 1.9.2
- Added State parameter to TSpTBXTextControl.OnDrawCaption
- Fixed incorrect Default property handling of TSpTBXButton,
thanks to Karpushin Matvey and Beta Xiong for reporting this.
1 December 2007 - version 1.9.1
- Added various painting enhancements made by Jim.
- Fixed incorrect caption color on the controls when
the Font is changed, thanks to Arvid and Zunyite for
reporting this.
- Fixed incorrect nested panel painting (canvas was not locked),
thanks to Jim for reporting this.
20 November 2007 - version 1.9
- Removed TBX dependency.
8 February 2007 - version 1.8.3
- Added GripHotTrack property to TSpTBXSplitter.
17 December 2006 - version 1.8.2
- Added AutoSize property to TSpTBXPanel.
- Fixed incorrect resizing behavior on TSpTBXSplitter when a
DockablePanel was adjacent.
24 November 2006 - version 1.8.1
- Improved TSpTBXPanel painting, thanks to Jim Kueneman for
his code donation.
- Fixed incorrect focus behavior on TSpTBXRadioButton when used
on a groupbox, thanks to Andrew for reporting this.
27 August 2006 - version 1.8
- Added DropDownArrow property to TSpTBXButton and TSpTBXSpeedButton.
- Fixed incorrect TSpTBXGroupBox painting when changing the
Enabled property, thanks to Tomaz Kunaver for reporting this.
15 June 2006 - version 1.7
- Fixed incorrect TSpTBXButton painting when using a bitmap
skin and the DropDownMenu is shown, thanks to Boris Yankov
for reporting this.
4 May 2006 - version 1.6
- New component added, TSpTBXRadioGroup.
12 April 2006 - version 1.5
- No changes.
27 February 2006 - version 1.4
- Added GroupIndex property to TSpTBXButton and TSpTBXSpeedButton.
10 February 2006 - version 1.3
- New component added, TSpTBXSpeedButton.
- New component added, TSpTBXSplitter.
- Fixed incorrect TSpTBXButton behavior when trying to close the
DropDownMenu clicking the button, thanks to Alexey Naumov for
reporting this.
==============================================================================}
interface
{$BOOLEVAL OFF} // Unit depends on short-circuit boolean evaluation
uses
Windows, Messages, Classes, SysUtils, Forms, Controls, Graphics, ImgList,
Menus, StdCtrls, ExtCtrls, ComCtrls, ActnList,
{$IFNDEF UNICODE}
TntClasses, TntControls,
{$ENDIF}
TB2Dock, TB2Toolbar, TB2Item, SpTBXItem, SpTBXSkins;
{$IFDEF UNICODE}
type
TTntStrings = TStrings;
{$ENDIF}
const
ConstStatesCount = 4; // Buttons have 4 states (normal, hottrack, pushed, disabled)
ConstInitRepeatPause = 400; // Delay of the first repeated click (ms)
ConstRepeatPause = 100; // Interval of the repeated clicks (ms)
CM_SPGROUPINDEXUPDATE = CM_BASE + 2222; // Message sent to the controls to update its state based on the GroupIndex
CM_SPTBXCONTROLSINVALIDATE = CM_BASE + 3333; // Message sent to SpTBX controls to invalidate the background
type
TSpTBXTextObject = class;
TSpTBXPanelBorder = (
pbrRaised,
pbrDoubleRaised,
pbrSunken,
pbrDoubleSunken,
pbrBumped,
pbrEtched,
pbrFramed
);
TSpTBXProgressCaption = (
pctNone,
pctDefault,
pctPercentage,
pctProgress
);
TSpTBXTickMark = (
tmxBottomRight,
tmxTopLeft,
tmxBoth,
tmxCenter
);
TSpTBXCanResizeEvent = procedure(Sender: TObject; var NewSize: Integer; var Accept: Boolean) of object;
{ TSpTBXPanel }
TSpTBXCustomPanel = class(TSpTBXCustomControl)
private
FBorders: Boolean;
FBorderType: TSpTBXPanelBorder;
FTBXStyleBackground: Boolean;
FSkinType: TSpTBXSkinType;
FOnDrawBackground: TSpTBXDrawEvent;
procedure SetBorders(const Value: Boolean);
procedure SetBorderType(const Value: TSpTBXPanelBorder);
procedure SetTBXStyleBackground(const Value: Boolean);
procedure SetSkinType(const Value: TSpTBXSkinType);
procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
procedure CMSpTBXControlsInvalidate(var Message: TMessage); message CM_SPTBXCONTROLSINVALIDATE;
procedure WMEraseBkgnd(var Message: TMessage); message WM_ERASEBKGND;
procedure WMSpSkinChange(var Message: TMessage); message WM_SPSKINCHANGE;
procedure WMWindowPosChanged(var Message: TWMWindowPosChanged); message WM_WINDOWPOSCHANGED;
protected
FBackground: TBitmap;
procedure AdjustClientRect(var Rect: TRect); override;
procedure CreateParams(var Params: TCreateParams); override;
procedure DrawBackground(ACanvas: TCanvas; ARect: TRect); virtual;
procedure DoDrawBackground(ACanvas: TCanvas; ARect: TRect; const PaintStage: TSpTBXPaintStage; var PaintDefault: Boolean); virtual;
property Borders: Boolean read FBorders write SetBorders default True;
property BorderType: TSpTBXPanelBorder read FBorderType write SetBorderType default pbrEtched;
property ParentColor default False;
property TBXStyleBackground: Boolean read FTBXStyleBackground write SetTBXStyleBackground default False;
property OnDrawBackground: TSpTBXDrawEvent read FOnDrawBackground write FOnDrawBackground;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure InvalidateBackground(InvalidateChildren: Boolean = True); virtual;
published
property Caption;
property Hint;
property Color default clNone;
property SkinType: TSpTBXSkinType read FSkinType write SetSkinType default sknSkin;
end;
TSpTBXPanel = class(TSpTBXCustomPanel)
private
FHotTracking: Boolean;
FHotTrack: Boolean;
FChildFocused: Boolean;
procedure SetHotTrack(const Value: Boolean);
procedure SetHotTracking(const Value: Boolean);
procedure CMMouseEnter(var Message: TMessage); message CM_MOUSEENTER;
procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE;
procedure CMFocusChanged(var Message: TCMFocusChanged); message CM_FOCUSCHANGED;
protected
procedure DrawBackground(ACanvas: TCanvas; ARect: TRect); override;
public
property HotTracking: Boolean read FHotTracking;
published
property Align;
property Anchors;
property AutoSize;
property BiDiMode;
property Constraints;
property UseDockManager;
property DockSite;
property DragCursor;
property DragKind;
property DragMode;
property Enabled;
property Font;
{$IF CompilerVersion > 15} // For Delphi 2005 and up
property Padding;
{$IFEND}
property ParentBiDiMode;
property ParentColor;
property ParentFont;
property ParentShowHint;
property PopupMenu;
property ShowHint;
property TabOrder;
property TabStop;
property Visible;
{$IF CompilerVersion > 15} // For Delphi 2005 and up
property OnAlignInsertBefore;
property OnAlignPosition;
{$IFEND}
property OnCanResize;
property OnClick;
property OnConstrainedResize;
property OnContextPopup;
property OnDockDrop;
property OnDockOver;
property OnDblClick;
property OnDragDrop;
property OnDragOver;
property OnEndDock;
property OnEndDrag;
property OnEnter;
property OnExit;
property OnGetSiteInfo;
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
property OnResize;
property OnStartDock;
property OnStartDrag;
property OnUnDock;
// TSpTBXCustomPanel properties
property Borders;
property BorderType;
property HotTrack: Boolean read FHotTrack write SetHotTrack default False;
property TBXStyleBackground;
property OnDrawBackground;
end;
{ TSpTBXGroupBox }
TSpTBXCustomGroupBox = class(TSpTBXCustomPanel)
private
procedure CMDialogChar(var Message: TCMDialogChar); message CM_DIALOGCHAR;
procedure CMTextChanged(var Message: TMessage); message CM_TEXTCHANGED;
protected
procedure AdjustClientRect(var Rect: TRect); override;
procedure DrawBackground(ACanvas: TCanvas; ARect: TRect); override;
public
constructor Create(AOwner: TComponent); override;
end;
TSpTBXGroupBox = class(TSpTBXCustomGroupBox)
published
property Align;
property Anchors;
property BiDiMode;
property Color;
property Constraints;
property UseDockManager;
property DockSite;
property DragCursor;
property DragKind;
property DragMode;
property Enabled;
property Font;
{$IF CompilerVersion > 15} // For Delphi 2005 and up
property Padding;
{$IFEND}
property ParentBiDiMode;
property ParentColor;
property ParentFont;
property ParentShowHint;
property PopupMenu;
property ShowHint;
property TabOrder;
property TabStop;
property Visible;
{$IF CompilerVersion > 15} // For Delphi 2005 and up
property OnAlignInsertBefore;
property OnAlignPosition;
{$IFEND}
property OnCanResize;
property OnClick;
property OnConstrainedResize;
property OnContextPopup;
property OnDockDrop;
property OnDockOver;
property OnDblClick;
property OnDragDrop;
property OnDragOver;
property OnEndDock;
property OnEndDrag;
property OnEnter;
property OnExit;
property OnGetSiteInfo;
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
property OnResize;
property OnStartDock;
property OnStartDrag;
property OnUnDock;
// TSpTBXCustomPanel properties
property Borders;
property BorderType;
property TBXStyleBackground;
property OnDrawBackground;
end;
{ TSpTBXTextObjectActionLink }
{$IFNDEF UNICODE}
TSpTBXTextObjectActionLink = class(TControlActionLink)
protected
FUnicodeClient: TSpTBXTextObject;
procedure AssignClient(AClient: TObject); override;
function IsCaptionLinked: Boolean; override;
function IsCheckedLinked: Boolean; override;
function IsHintLinked: Boolean; override;
procedure SetCaption(const Value: String); override;
procedure SetChecked(Value: Boolean); override;
procedure SetHint(const Value: String); override;
procedure SetImageIndex(Value: Integer); override;
end;
{$ELSE}
TSpTBXTextObjectActionLink = class(TControlActionLink);
{$ENDIF}
{ TSpTBXTextObject }
TSpTBXTextObject = class(TSpTBXCustomControl)
private
FAlignment: TAlignment;
FCaptionGlow: TSpGlowDirection;
FCaptionGlowColor: TColor;
FCaptionRoatationAngle: TSpTextRotationAngle;
FChecked: Boolean;
FDisabledIconCorrection: Boolean;
FDrawPushedCaption: Boolean;
FGlyphLayout: TSpGlyphLayout;
FImages: TCustomImageList;
FImageChangeLink: TChangeLink;
FImageIndex: TImageIndex;
FLinkText: WideString;
FLinkTextParams: WideString;
FMouseInControl: Boolean;
FPushed: Boolean;
FSkinType: TSpTBXSkinType;
FSpaceAsClick: Boolean;
FShowAccelChar: Boolean;
FUpdating: Boolean;
FWrapping: TTextWrapping;
FOnDraw: TSpTBXDrawEvent;
FOnDrawCaption: TSpTBXDrawTextEvent;
FOnDrawHint: TSpTBXDrawHintEvent;
FOnGetImageIndex: TSpTBXGetImageIndexEvent;
FOnMouseEnter: TNotifyEvent;
FOnMouseLeave: TNotifyEvent;
procedure ReadLinkFont(Reader: TReader); // [Backward-Compatibility]
procedure ImageListChange(Sender: TObject);
procedure UpdateTracking(ForceMouseLeave: Boolean = False);
procedure SetAlignment(const Value: TAlignment);
procedure SetCaptionGlow(const Value: TSpGlowDirection);
procedure SetCaptionGlowColor(const Value: TColor);
procedure SetCaptionRoatationAngle(const Value: TSpTextRotationAngle);
procedure SetGlyphLayout(const Value: TSpGlyphLayout);
procedure SetImageIndex(const Value: TImageIndex);
procedure SetImages(const Value: TCustomImageList);
procedure SetSkinType(const Value: TSpTBXSkinType);
procedure SetShowAccelChar(Value: Boolean);
procedure SetWrapping(Value: TTextWrapping);
procedure CMEnabledChanged(var Message: TMessage); message CM_ENABLEDCHANGED;
procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
procedure CMHintShow(var Message: TCMHintShow); message CM_HINTSHOW;
procedure CMMouseEnter(var Message: TMessage); message CM_MOUSEENTER;
procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE;
procedure CMTextChanged(var Message: TMessage); message CM_TEXTCHANGED;
procedure WMEraseBkgnd(var Message: TMessage); message WM_ERASEBKGND;
procedure WMKillFocus(var Message: TMessage); message WM_KILLFOCUS;
procedure WMSetFocus(var Message: TMessage); message WM_SETFOCUS;
procedure WMSetCursor(var Message: TWMSetCursor); message WM_SETCURSOR;
procedure WMSpSkinChange(var Message: TMessage); message WM_SPSKINCHANGE;
protected
// Painting
procedure AdjustFont(AFont: TFont); virtual;
procedure AdjustBounds;
procedure DoDrawHint(AHintBitmap: TBitmap; var AHint: Widestring; var PaintDefault: Boolean); virtual;
function DoDrawItem(ACanvas: TCanvas; ARect: TRect; const PaintStage: TSpTBXPaintStage): Boolean; virtual;
function DoDrawText(ACanvas: TCanvas; var ARect: TRect; Flags: Longint): Integer; virtual;
procedure DoGetImageIndex(var AImageList: TCustomImageList; var AImageIndex: Integer); virtual;
procedure DoInternalGlyphDraw(ACanvas: TCanvas; AGlyphRect: TRect); virtual;
function GetFocusRect(R, TextR, GlyphR: TRect): TRect; virtual;
function GetTextMargins: TRect; virtual;
function IsImageIndexValid: Boolean;
procedure Paint; override;
// Sizing
function CanAutoSize(var NewWidth, NewHeight: Integer): Boolean; override;
procedure DoAdjustBounds(var NewWidth, NewHeight: Integer); virtual;
// Mouse
function GetFocused: Boolean; virtual;
function GetPushed: Boolean; virtual;
procedure DoMouseEnter; virtual;
procedure DoMouseLeave; virtual;
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 KeyDown(var Key: Word; Shift: TShiftState); override;
procedure KeyUp(var Key: Word; Shift: TShiftState); override;
// Component
procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override;
procedure CreateParams(var Params: TCreateParams); override;
procedure DefineProperties(Filer: TFiler); override;
procedure ExecuteLink; virtual;
function GetActionLinkClass: TControlActionLinkClass; override;
function GetChecked: Boolean; virtual;
procedure SetChecked(Value: Boolean); virtual;
procedure Loaded; override;
procedure Notification(AComponent: TComponent; Operation: TOperation); override;
property Alignment: TAlignment read FAlignment write SetAlignment default taLeftJustify;
property AutoSize default True;
property Checked: Boolean read GetChecked write SetChecked default False;
property CaptionGlow: TSpGlowDirection read FCaptionGlow write SetCaptionGlow default gldNone;
property CaptionGlowColor: TColor read FCaptionGlowColor write SetCaptionGlowColor default clYellow;
property CaptionRoatationAngle: TSpTextRotationAngle read FCaptionRoatationAngle write SetCaptionRoatationAngle default tra0;
property DrawPushedCaption: Boolean read FDrawPushedCaption write FDrawPushedCaption default False;
property DisabledIconCorrection: Boolean read FDisabledIconCorrection write FDisabledIconCorrection default True;
property GlyphLayout: TSpGlyphLayout read FGlyphLayout write SetGlyphLayout default ghlGlyphLeft;
property Images: TCustomImageList read FImages write SetImages;
property ImageIndex: TImageIndex read FImageIndex write SetImageIndex default -1;
property LinkText: WideString read FLinkText write FLinkText;
property LinkTextParams: WideString read FLinkTextParams write FLinkTextParams;
property SkinType: TSpTBXSkinType read FSkinType write SetSkinType default sknSkin;
property ShowAccelChar: Boolean read FShowAccelChar write SetShowAccelChar default True;
property SpaceAsClick: Boolean read FSpaceAsClick write FSpaceAsClick default False;
property Wrapping: TTextWrapping read FWrapping write SetWrapping default twNone;
property OnDraw: TSpTBXDrawEvent read FOnDraw write FOnDraw;
property OnDrawCaption: TSpTBXDrawTextEvent read FOnDrawCaption write FOnDrawCaption;
property OnDrawHint: TSpTBXDrawHintEvent read FOnDrawHint write FOnDrawHint;
property OnGetImageIndex: TSpTBXGetImageIndexEvent read FOnGetImageIndex write FOnGetImageIndex;
property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter;
property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;
property TabStop default True;
property ParentColor default False;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
function CanFocus: Boolean; override;
procedure Click; override;
function GetControlsAlignment: TAlignment; override;
procedure GetSize(out TotalR, TextR, GlyphR: TRect); virtual;
function GetTextFlags: Cardinal;
function GetGlyphSize: TSize; virtual;
property Canvas;
property MouseInControl: Boolean read FMouseInControl;
property Pushed: Boolean read GetPushed;
published
property Caption;
property Hint;
property Color default clNone;
end;
{ TSpTBXLabel }
TSpTBXCustomLabel = class(TSpTBXTextObject)
private
FFocusControl: TWinControl;
FUnderline: Boolean;
FUnderlineColor: TColor;
procedure SetFocusControl(const Value: TWinControl);
procedure SetUnderline(const Value: Boolean);
procedure SetUnderlineColor(const Value: TColor);
procedure CMDialogChar(var Message: TCMDialogChar); message CM_DIALOGCHAR;
protected
procedure AdjustFont(AFont: TFont); override;
function DoDrawItem(ACanvas: TCanvas; ARect: TRect; const PaintStage: TSpTBXPaintStage): Boolean; override;
procedure Notification(AComponent: TComponent; Operation: TOperation); override;
property FocusControl: TWinControl read FFocusControl write SetFocusControl;
property Underline: Boolean read FUnderline write SetUnderline default False;
property UnderlineColor: TColor read FUnderlineColor write SetUnderlineColor default clBtnShadow;
public
constructor Create(AOwner: TComponent); override;
procedure GetSize(out TotalR: TRect; out TextR: TRect; out GlyphR: TRect); override;
end;
TSpTBXLabel = class(TSpTBXCustomLabel)
published
property Action;
property Align;
property Anchors;
property AutoSize;
property BiDiMode;
property Color;
property Constraints;
property DragCursor;
property DragKind;
property DragMode;
property Enabled;
property Font;
property ParentBiDiMode;
property ParentColor;
property ParentFont;
property ParentShowHint;
property PopupMenu;
property ShowAccelChar;
property ShowHint;
property Visible;
property Wrapping;
property OnClick;
property OnContextPopup;
property OnDblClick;
property OnDragDrop;
property OnDragOver;
property OnEndDock;
property OnEndDrag;
property OnMouseDown;
property OnMouseEnter;
property OnMouseLeave;
property OnMouseMove;
property OnMouseUp;
property OnStartDock;
property OnStartDrag;
// TSpTBXCustomLabel properties
property Alignment;
property CaptionGlow;
property CaptionGlowColor;
property FocusControl;
property GlyphLayout;
property Images;
property ImageIndex;
property LinkText;
property LinkTextParams;
property SkinType;
property Underline;
property UnderlineColor;
property OnDraw;
property OnDrawCaption;
property OnDrawHint;
property OnGetImageIndex;
end;
{ TSpTBXButtonControl }
TSpTBXButtonControl = class(TSpTBXTextObject)
private
FAllowAllUp: Boolean;
FGroupIndex: Integer;
FStateChanged: Boolean;
procedure SetAllowAllUp(const Value: Boolean);
procedure SetGroupIndex(const Value: Integer);
procedure CMDialogChar(var Message: TCMDialogChar); message CM_DIALOGCHAR;
procedure CMSPGroupIndexUpdate(var Message: TMessage); message CM_SPGROUPINDEXUPDATE;
protected
function CanUpdateExclusive: Boolean; virtual;
procedure SetChecked(Value: Boolean); override;
procedure UpdateExclusive;
property AllowAllUp: Boolean read FAllowAllUp write SetAllowAllUp default False;
property GroupIndex: Integer read FGroupIndex write SetGroupIndex default 0;
property StateChanged: Boolean read FStateChanged write FStateChanged;
public
constructor Create(AOwner: TComponent); override;
function CanFocus: Boolean; override;
end;
{ TSpTBXCheckBox }
TSpTBXCustomCheckButton = class(TSpTBXButtonControl)
protected
procedure Toggle; virtual;
public
function GetGlyphSize: TSize; override;
procedure GetSize(out TotalR, TextR, GlyphR: TRect); override;
end;
TSpTBXCustomCheckBox = class(TSpTBXCustomCheckButton)
private
FAllowGrayed: Boolean;
FState: TCheckBoxState;
procedure SetState(const Value: TCheckBoxState);
protected
procedure AdjustFont(AFont: TFont); override;
procedure DoInternalGlyphDraw(ACanvas: TCanvas; AGlyphRect: TRect); override;
function GetChecked: Boolean; override;
procedure SetChecked(Value: Boolean); override;
procedure Toggle; override;
property AllowGrayed: Boolean read FAllowGrayed write FAllowGrayed default False;
property State: TCheckBoxState read FState write SetState default cbUnchecked;
public
constructor Create(AOwner: TComponent); override;
procedure Click; override;
end;
TSpTBXCheckBox = class(TSpTBXCustomCheckBox)
published
property Action;
property Align;
property Anchors;
property AutoSize;
property BiDiMode;
property Color;
property Constraints;
property DragCursor;
property DragKind;
property DragMode;
property Enabled;
property Font;
property ParentBiDiMode;
property ParentColor;
property ParentFont;
property ParentShowHint;
property PopupMenu;
property ShowAccelChar;
property ShowHint;
property TabOrder;
property TabStop;
property Visible;
property Wrapping;
property OnClick;
property OnContextPopup;
property OnDblClick;
property OnDragDrop;
property OnDragOver;
property OnEndDock;
property OnEndDrag;
property OnMouseDown;
property OnMouseEnter;
property OnMouseLeave;
property OnMouseMove;
property OnMouseUp;
property OnStartDock;
property OnStartDrag;
// TSpTBXCustomCheckBox properties
property Alignment;
property AllowGrayed;
property CaptionGlow;
property CaptionGlowColor;
property Checked;
property State;
property SkinType;
property OnDraw;
property OnDrawCaption;
property OnDrawHint;
property OnGetImageIndex;
end;
{ TSpTBXRadioButton }
TSpTBXCustomRadioButton = class(TSpTBXCustomCheckButton)
private
procedure CMFocusChanged(var Message: TCMFocusChanged); message CM_FOCUSCHANGED;
protected
procedure AdjustFont(AFont: TFont); override;
function CanUpdateExclusive: Boolean; override;
procedure DoInternalGlyphDraw(ACanvas: TCanvas; AGlyphRect: TRect); override;
procedure SetChecked(Value: Boolean); override;
procedure Toggle; override;
property TabStop default False;
public
constructor Create(AOwner: TComponent); override;
procedure Click; override;
end;
TSpTBXRadioButton = class(TSpTBXCustomRadioButton)
published
property Action;
property Align;
property Anchors;
property AutoSize;
property BiDiMode;
property Color;
property Constraints;
property DragCursor;
property DragKind;
property DragMode;
property Enabled;
property Font;
property ParentBiDiMode;
property ParentColor;
property ParentFont;
property ParentShowHint;
property PopupMenu;
property ShowAccelChar;
property ShowHint;
property TabOrder;
property TabStop;
property Visible;
property Wrapping;
property OnClick;
property OnContextPopup;
property OnDblClick;
property OnDragDrop;
property OnDragOver;
property OnEndDock;
property OnEndDrag;
property OnMouseDown;
property OnMouseEnter;
property OnMouseLeave;
property OnMouseMove;
property OnMouseUp;
property OnStartDock;
property OnStartDrag;
// TSpTBXCustomRadioButton properties
property Alignment;
property CaptionGlow;
property CaptionGlowColor;
property Checked;
property GroupIndex;
property SkinType;
property OnDraw;
property OnDrawCaption;
property OnDrawHint;
property OnGetImageIndex;
end;
{ TSpTBXRadioGroup }
TSpTBXCustomRadioGroup = class(TSpTBXCustomGroupBox)
private
FButtons: TList;
FItems: TTntStrings;
FItemIndex: Integer;
FColumns: Integer;
FReading: Boolean;
FUpdating: Boolean;
function GetButtons(Index: Integer): TSpTBXRadioButton;
procedure ArrangeButtons;
procedure ButtonClick(Sender: TObject);
procedure ItemsChange(Sender: TObject);
procedure SetButtonCount(Value: Integer);
procedure SetColumns(Value: Integer);
procedure SetItemIndex(Value: Integer);
procedure SetItems(Value: TTntStrings);
procedure UpdateButtons;
procedure CMEnabledChanged(var Message: TMessage); message CM_ENABLEDCHANGED;
procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
procedure WMSize(var Message: TWMSize); message WM_SIZE;
protected
procedure Loaded; override;
procedure ReadState(Reader: TReader); override;
property Columns: Integer read FColumns write SetColumns default 1;
property ItemIndex: Integer read FItemIndex write SetItemIndex default -1;
property Items: TTntStrings read FItems write SetItems;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure GetChildren(Proc: TGetChildProc; Root: TComponent); override;
procedure FlipChildren(AllLevels: Boolean); override;
procedure InvalidateBackground(InvalidateChildren: Boolean = True); override;
procedure SetFocus; override;
property Buttons[Index: Integer]: TSpTBXRadioButton read GetButtons;
end;
TSpTBXRadioGroup = class(TSpTBXCustomRadioGroup)
published
property Align;
property Anchors;
property BiDiMode;
property Color;
property Constraints;
property UseDockManager;
property DockSite;
property DragCursor;
property DragKind;
property DragMode;
property Enabled;
property Font;
property ParentBiDiMode;
property ParentColor;
property ParentFont;
property ParentShowHint;
property PopupMenu;
property ShowHint;
property TabOrder;
property TabStop;
property Visible;
property OnCanResize;
property OnClick;
property OnConstrainedResize;
property OnContextPopup;
property OnDockDrop;
property OnDockOver;
property OnDblClick;
property OnDragDrop;
property OnDragOver;
property OnEndDock;
property OnEndDrag;
property OnEnter;
property OnExit;
property OnGetSiteInfo;
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
property OnResize;
property OnStartDock;
property OnStartDrag;
property OnUnDock;
// TSpTBXCustomPanel properties
property Borders;
property BorderType;
property TBXStyleBackground;
property OnDrawBackground;
// TSpTBXCustomRadioGroup properties
property Columns;
property ItemIndex;
property Items;
end;
{ TSpTBXButton }
TSpTBXCustomButton = class(TSpTBXButtonControl)
private
FBitmap: TBitmap;
FBitmapTransparent: Boolean;
FActive: Boolean;
FCancel: Boolean;
FDefault: Boolean;
FDropDownArrow: Boolean;
FDropDownMenu: TPopupMenu;
FDropDownMenuVisible: Boolean;
FFlat: Boolean;
FModalResult: TModalResult;
FRepeating: Boolean;
FRepeatTimer: TTimer;
FToolbarStyle: Boolean;
procedure BitmapChanged(Sender: TObject);
procedure RepeatTimerHandler(Sender: TObject);
procedure SetBitmap(const Value: TBitmap);
procedure SetDefault(const Value: Boolean);
procedure SetDropDownArrow(const Value: Boolean);
procedure SetDropdownMenu(Value: TPopupMenu);
procedure SetFlat(const Value: Boolean);
procedure CMDialogKey(var Message: TCMDialogKey); message CM_DIALOGKEY;
procedure CMFocusChanged(var Message: TCMFocusChanged); message CM_FOCUSCHANGED;
procedure CMSPPopupClose(var Message: TMessage); message CM_SPPOPUPCLOSE;
procedure WMCancelMode(var Message: TWMCancelMode); message WM_CANCELMODE;
protected
FPopupControl: TControl;
procedure CreateWnd; override;
procedure AdjustFont(AFont: TFont); override;
function BitmapValid: boolean;
function DoDrawDropDownArrow(ACanvas: TCanvas; ARect: TRect): Boolean; virtual;
function DoDrawItem(ACanvas: TCanvas; ARect: TRect; const PaintStage: TSpTBXPaintStage): Boolean; override;
function GetFocused: Boolean; override;
function GetFocusRect(R, TextR, GlyphR: TRect): TRect; override;
function GetInternalDropDownMenu: TPopupMenu; virtual;
function GetPushed: Boolean; override;
function GetTextMargins: TRect; override;
procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
procedure Notification(AComponent: TComponent; Operation: TOperation); override;
property Alignment default taCenter;
property Bitmap: TBitmap read FBitmap write SetBitmap;
property BitmapTransparent: Boolean read FBitmapTransparent write FBitmapTransparent default True;
property DrawPushedCaption default True;
property Cancel: Boolean read FCancel write FCancel default False;
property Default: Boolean read FDefault write SetDefault default False;
property DropDownArrow: Boolean read FDropDownArrow write SetDropDownArrow default True;
property DropDownMenu: TPopupMenu read FDropDownMenu write SetDropDownMenu;
property Flat: Boolean read FFlat write SetFlat default False;
property ModalResult: TModalResult read FModalResult write FModalResult default 0;
property Repeating: Boolean read FRepeating write FRepeating default False;
property ToolbarStyle: Boolean read FToolbarStyle write FToolbarStyle default False;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure Click; override;
function GetSkinStateRect: TRect;
function IsDroppedDown: Boolean;
procedure StopRepeat; virtual;
end;
TSpTBXButton = class(TSpTBXCustomButton)
published
property Action;
property Align;
property Anchors;
property BiDiMode;
property Color;
property Constraints;
property DragCursor;
property DragKind;
property DragMode;
property Enabled;
property Font;
property ParentBiDiMode;
property ParentColor;
property ParentFont;
property ParentShowHint;
property PopupMenu;
property ShowAccelChar;
property ShowHint;
property TabOrder;
property TabStop;
property Visible;
property Wrapping;
property OnClick;
property OnContextPopup;
// property OnDblClick; Buttons don't have OnDblClick events
property OnDragDrop;
property OnDragOver;
property OnEndDock;
property OnEndDrag;
property OnMouseDown;
property OnMouseEnter;
property OnMouseLeave;
property OnMouseMove;
property OnMouseUp;
property OnStartDock;
property OnStartDrag;
// TSpTBXCustomButton properties
property Alignment;
property Bitmap;
property BitmapTransparent;
property Cancel;
property CaptionGlow;
property CaptionGlowColor;
property Checked;
property Default;
property DrawPushedCaption;
property DropDownArrow;
property DropDownMenu;
property Flat;
property GlyphLayout;
property GroupIndex;
property Images;
property ImageIndex;
property LinkText;
property LinkTextParams;
property ModalResult;
property SkinType;
property Repeating;
property OnDraw;
property OnDrawCaption;
property OnDrawHint;
property OnGetImageIndex;
end;
{ TSpTBXSpeedButton }
TSpTBXCustomSpeedButton = class(TSpTBXCustomButton)
public
constructor Create(AOwner: TComponent); override;
function CanFocus: Boolean; override;
procedure Click; override;
end;
TSpTBXSpeedButton = class(TSpTBXCustomSpeedButton)
published
property Action;
property Align;
property Anchors;
property BiDiMode;
property Color;
property Constraints;
property DragCursor;
property DragKind;
property DragMode;
property Enabled;
property Font;
property ParentBiDiMode;
property ParentColor;
property ParentFont;
property ParentShowHint;
property PopupMenu;
property ShowAccelChar;
property ShowHint;
// property TabOrder; SpeedButtons don't have TabStops
// property TabStop; SpeedButtons don't have TabStops
property Visible;
property Wrapping;
property OnClick;
property OnContextPopup;
// property OnDblClick; SpeedButtons don't have OnDblClick events
property OnDragDrop;
property OnDragOver;
property OnEndDock;
property OnEndDrag;
property OnMouseDown;
property OnMouseEnter;
property OnMouseLeave;
property OnMouseMove;
property OnMouseUp;
property OnStartDock;
property OnStartDrag;
// TSpTBXCustomButton properties
property Alignment;
property AllowAllUp;
property Bitmap;
property BitmapTransparent;
property Cancel;
property CaptionGlow;
property CaptionGlowColor;
property Checked;
property Default;
property DrawPushedCaption;
property DropDownArrow;
property DropDownMenu;
property Flat;
property GlyphLayout;
property GroupIndex;
property Images;
property ImageIndex;
property LinkText;
property LinkTextParams;
property SkinType;
property Repeating;
property OnDraw;
property OnDrawCaption;
property OnDrawHint;
property OnGetImageIndex;
end;
{ TSpTBXProgressBar }
TSpTBXProgressBarChangeEvent = procedure(Sender: TObject; NewPosition: Integer) of object;
TSpTBXCustomProgressBar = class(TSpTBXTextObject)
private
FMin: Integer;
FMax: Integer;
FPosition: Integer;
FProgressVisible: Boolean;
FSmooth: Boolean;
FVertical: Boolean;
FCaptionType: TSpTBXProgressCaption;
FOnProgressChange: TSpTBXProgressBarChangeEvent;
procedure SetMax(const Value: integer);
procedure SetMin(const Value: integer);
procedure SetPosition(Value: integer);
procedure SetSmooth(const Value: Boolean);
procedure SetVertical(const Value: Boolean);
procedure SetCaptionType(const Value: TSpTBXProgressCaption);
procedure SetProgressVisible(const Value: Boolean);
protected
procedure AdjustFont(AFont: TFont); override;
function DoDrawItem(ACanvas: TCanvas; ARect: TRect; const PaintStage: TSpTBXPaintStage): Boolean; override;
procedure DoProgressChange; virtual;
function GetTextMargins: TRect; override;
property Alignment default taCenter;
property CaptionGlow default gldAll;
property CaptionType: TSpTBXProgressCaption read FCaptionType write SetCaptionType default pctPercentage;
property Max: Integer read FMax write SetMax default 100;
property Min: Integer read FMin write SetMin default 0;
property Position: Integer read FPosition write SetPosition default 0;
property ProgressVisible: Boolean read FProgressVisible write SetProgressVisible default True;
property Smooth: Boolean read FSmooth write SetSmooth default False;
property Vertical: Boolean read FVertical write SetVertical default False;
property OnProgressChange: TSpTBXProgressBarChangeEvent read FOnProgressChange write FOnProgressChange;
public
constructor Create(AOwner: TComponent); override;
procedure StepIt(Delta: Integer = 1);
end;
TSpTBXProgressBar = class(TSpTBXCustomProgressBar)
published
property Align;
property Anchors;
property Color;
property Constraints;
property DragCursor;
property DragKind;
property DragMode;
property Enabled;
property Font;
property ParentColor;
property ParentFont;
property ParentShowHint;
property PopupMenu;
property ShowHint;
property Visible;
property OnClick;
property OnContextPopup;
property OnDblClick;
property OnDragDrop;
property OnDragOver;
property OnEndDock;
property OnEndDrag;
property OnMouseDown;
property OnMouseEnter;
property OnMouseLeave;
property OnMouseMove;
property OnMouseUp;
property OnStartDock;
property OnStartDrag;
// TSpTBXCustomProgressBar properties
property Alignment;
property CaptionGlow;
property CaptionGlowColor;
property CaptionType;
property Max;
property Min;
property Position;
property Smooth;
property Vertical;
property SkinType;
property OnDraw;
property OnDrawCaption;
property OnDrawHint;
property OnProgressChange;
end;
{ TSpTBXTrackBar }
TSpTBXTrackBar = class(TTrackBar)
private
FSkinType: TSpTBXSkinType;
FTickMarks: TSpTBXTickMark;
FOnDrawChannel: TSpTBXDrawEvent;
FOnDrawChannelTicks: TSpTBXDrawPosEvent;
FOnDrawThumb: TSpTBXDrawEvent;
FCanDrawChannelSelection: Boolean;
procedure SetSkinType(const Value: TSpTBXSkinType);
procedure SetTickMarks(const Value: TSpTBXTickMark);
procedure CMSpTBXControlsInvalidate(var Message: TMessage); message CM_SPTBXCONTROLSINVALIDATE;
procedure CNNotify(var Message: TWMNotify); message CN_NOTIFY;
procedure WMEraseBkGnd(var Message: TMessage); message WM_ERASEBKGND;
procedure WMSpSkinChange(var Message: TMessage); message WM_SPSKINCHANGE;
protected
procedure CreateParams(var Params: TCreateParams); override;
function DoDrawChannel(ACanvas: TCanvas; ARect: TRect; const PaintStage: TSpTBXPaintStage): Boolean; virtual;
function DoDrawChannelTicks(ACanvas: TCanvas; X, Y: Integer): Boolean; virtual;
function DoDrawThumb(ACanvas: TCanvas; ARect: TRect; const PaintStage: TSpTBXPaintStage): Boolean; virtual;
procedure DrawTicks(ACanvas: TCanvas); virtual;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
function ChannelRect: TRect;
function MouseInThumb: Boolean;
procedure InvalidateBackground;
published
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
property SkinType: TSpTBXSkinType read FSkinType write SetSkinType default sknSkin;
property TickMarks: TSpTBXTickMark read FTickMarks write SetTickMarks default tmxBottomRight;
property OnDrawChannel: TSpTBXDrawEvent read FOnDrawChannel write FOnDrawChannel;
property OnDrawChannelTicks: TSpTBXDrawPosEvent read FOnDrawChannelTicks write FOnDrawChannelTicks;
property OnDrawThumb: TSpTBXDrawEvent read FOnDrawThumb write FOnDrawThumb;
end;
{ Painting helpers }
procedure SpDrawXPPanel(ACanvas: TCanvas; ARect: TRect; Enabled, TBXStyleBackground: Boolean; SkinType: TSpTBXSkinType; Border: TSpTBXPanelBorder);
procedure SpDrawXPPanelBorder(ACanvas: TCanvas; ARect: TRect; Border: TSpTBXPanelBorder);
procedure SpDrawXPGroupBox(ACanvas: TCanvas; ARect: TRect; ACaption: WideString; TextFlags: Cardinal; Enabled, TBXStyleBackground: Boolean; SkinType: TSpTBXSkinType);
procedure SpDrawXPProgressBar(ACanvas: TCanvas; ARect: TRect; Min, Max, Position: Integer; Back, Fore: TBitmap); overload;
function SpDrawXPProgressBar(ACanvas: TCanvas; ARect: TRect; Vertical, Smooth, DrawProgress: Boolean; Min, Max, Position: Integer; SkinType: TSpTBXSkinType): Integer; overload;
procedure SpDrawXPTrackBar(ACanvas: TCanvas; ARect: TRect; Part: Cardinal; Vertical, Pushed, ChannelSelection: Boolean; TickMark: TSpTBXTickMark; Min, Max, SelStart, SelEnd: Integer; SkinType: TSpTBXSkinType);
procedure SpInvalidateSpTBXControl(AControl: TWinControl; InvalidateChildren, OnlySpTBXControls: Boolean);
implementation
uses
Themes, UxTheme,
{$IFNDEF UNICODE} TntActnList, {$ENDIF}
CommCtrl, ShellAPI;
type
TWinControlAccess = class(TWinControl);
//WMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWM
{ Helpers }
procedure SpDrawXPPanel(ACanvas: TCanvas; ARect: TRect; Enabled, TBXStyleBackground: Boolean;
SkinType: TSpTBXSkinType; Border: TSpTBXPanelBorder);
var
Flags: Integer;
begin
case SpTBXSkinType(SkinType) of
sknWindows:
begin
if Enabled then Flags := GBS_NORMAL
else Flags := GBS_DISABLED;
DrawThemeBackground(ThemeServices.Theme[teButton], ACanvas.Handle, BP_GROUPBOX, Flags, ARect, nil);
end;
sknNone:
SpDrawXPPanelBorder(ACanvas, ARect, Border);
sknSkin:
CurrentSkin.PaintBackground(ACanvas, ARect, skncPanel, sknsNormal, TBXStyleBackground, True);
end;
end;
procedure SpDrawXPPanelBorder(ACanvas: TCanvas; ARect: TRect; Border: TSpTBXPanelBorder);
const
Edge: array [TSpTBXPanelBorder] of Cardinal = (BDR_RAISEDINNER, EDGE_RAISED,
BDR_SUNKENOUTER, EDGE_SUNKEN, EDGE_BUMP, EDGE_ETCHED, 0);
begin
if Border = pbrFramed then begin
ACanvas.Brush.Color := clBtnFace;
ACanvas.FrameRect(ARect);
end
else
DrawEdge(ACanvas.Handle, ARect, Edge[Border], BF_RECT);
end;
procedure SpDrawXPGroupBox(ACanvas: TCanvas; ARect: TRect; ACaption: WideString;
TextFlags: Cardinal; Enabled, TBXStyleBackground: Boolean; SkinType: TSpTBXSkinType);
var
Width, Flags, SaveIndex: Integer;
R: TRect;
CaptionRect: TRect;
begin
Flags := 0;
SkinType := SpTBXSkinType(SkinType);
Width := ARect.Right - ARect.Left;
if ACaption <> '' then begin
CaptionRect := Rect(0, 0, 1, 1);
if Enabled then Flags := GBS_NORMAL
else Flags := GBS_DISABLED;
if SkinType = sknWindows then
GetThemeTextExtent(ThemeServices.Theme[teButton], ACanvas.Handle, BP_GROUPBOX, Flags,
PWideChar(ACaption), Length(ACaption), DT_LEFT, nil, CaptionRect)
else
SpDrawXPText(ACanvas, ACaption, CaptionRect, TextFlags or DT_CALCRECT);
if (TextFlags and DT_RTLREADING) = 0 then
OffsetRect(CaptionRect, 8, 0)
else
OffsetRect(CaptionRect, Width - 8 - CaptionRect.Right, 0);
end
else
CaptionRect := Rect(0, 0, 0, 0);
R := ARect;
R.Top := (CaptionRect.Bottom - CaptionRect.Top) div 2;
SaveIndex := SaveDC(ACanvas.Handle);
with CaptionRect do
ExcludeClipRect(ACanvas.Handle, Left, Top, Right, Bottom);
try
SpDrawXPPanel(ACanvas, R, Enabled, TBXStyleBackground, SkinType, pbrEtched);
finally
RestoreDC(ACanvas.Handle, SaveIndex);
end;
if ACaption <> '' then begin
case SkinType of
sknNone:
SpDrawXPText(ACanvas, ACaption, CaptionRect, TextFlags);
sknWindows:
DrawThemeText(ThemeServices.Theme[teButton], ACanvas.Handle, BP_GROUPBOX, Flags, PWideChar(ACaption), -1, TextFlags, 0, CaptionRect);
sknSkin:
begin
if CurrentSkin.Options(skncPanel, sknsNormal).TextColor <> clNone then
ACanvas.Font.Color := CurrentSkin.Options(skncPanel, sknsNormal).TextColor;
SpDrawXPText(ACanvas, ACaption, CaptionRect, TextFlags);
end;
end;
end;
end;
procedure SpDrawXPProgressBar(ACanvas: TCanvas; ARect: TRect;
Min, Max, Position: Integer; Back, Fore: TBitmap);
var
Percent, Delta: Integer;
DeltaR, R: TRect;
begin
if Position < Min then Position := Min
else if Position > Max then Position := Max;
// Get the delta
if (Max > Min) and (Position > Min) then begin
Percent := (Position * 100) div (Max - Min);
DeltaR := ARect;
R := Rect(0, 0, Back.Width, Back.Height);
if Back.Height > Back.Width then begin
Delta := (Back.Height * Percent) div 100;
DeltaR.Bottom := DeltaR.Top + Delta;
R.Bottom := R.Top + Delta;
end
else begin
Delta := (Back.Width * Percent) div 100;
DeltaR.Right := DeltaR.Left + Delta;
R.Right := R.Left + Delta;
end;
end
else
Delta := 0;
ACanvas.Draw(ARect.Left, ARect.Top, Back);
if Delta > 0 then
ACanvas.CopyRect(DeltaR, Fore.Canvas, R);
end;
function SpDrawXPProgressBar(ACanvas: TCanvas; ARect: TRect;
Vertical, Smooth, DrawProgress: Boolean; Min, Max, Position: Integer;
SkinType: TSpTBXSkinType): Integer;
const
PartID: array [Boolean] of Integer = (PP_BAR, PP_BARVERT);
VistaPartID: array [Boolean] of Integer = (5, 6); // PP_FILL, PP_FILLVERT
ChunkID: array [Boolean] of Integer = (PP_CHUNK, PP_CHUNKVERT);
var
ChunkPaint: Boolean;
I: Integer;
DeltaR, R: TRect;
B: TBitmap;
Percentage: Double;
begin
Result := 0;
ChunkPaint := False;
if Position < Min then Position := Min
else if Position > Max then Position := Max;
SkinType := SpTBXSkinType(SkinType);
// Get the delta
if (Max > Min) and (Position > Min) then begin
DeltaR := ARect;
case SkinType of
sknWindows:
if not SpIsWinVistaOrUp then
if Vertical then InflateRect(DeltaR, -3, -4)
else InflateRect(DeltaR, -4, -3);
sknNone: InflateRect(DeltaR, -2, -2);
end;
// Cast Position to a Double real type, otherwise Percentage * 100
// returns a negative value, e.g. 30000000 * 100
Percentage := Position;
Percentage := (Percentage * 100) / (Max - Min);
Result := Round(Percentage);
if Vertical then
DeltaR.Top := DeltaR.Bottom - (((DeltaR.Bottom - DeltaR.Top) * Result) div 100)
else
DeltaR.Right := DeltaR.Left + (((DeltaR.Right - DeltaR.Left) * Result) div 100);
end
else
DeltaR := Rect(0, 0, 0, 0);
B := TBitmap.Create;
try
case SkinType of
sknWindows:
begin
DrawThemeBackground(ThemeServices.Theme[teProgress], ACanvas.Handle, PartID[Vertical], 0, ARect, nil);
if DrawProgress and not IsRectEmpty(DeltaR) then begin
if SpIsWinVistaOrUp then
DrawThemeBackground(ThemeServices.Theme[teProgress], ACanvas.Handle, VistaPartID[Vertical], 1, DeltaR, nil)
else begin
// [Theme-Change]
// Another Windows API bug, Windows XP progress bar chunks are 8 x 11,
// but DrawThemeBackground draws 10 x 11 chunks. We must draw the chunks manually.
if Vertical then begin
B.Width := DeltaR.Right - DeltaR.Left;
B.Height := 8;
R := Rect(0, 2, B.Width, B.Height);
end
else begin
B.Width := 8;
B.Height := DeltaR.Bottom - DeltaR.Top;
R := Rect(0, 0, B.Width - 2, B.Height);
end;
DrawThemeBackground(ThemeServices.Theme[teProgress], B.Canvas.Handle, ChunkID[Vertical], 0, R, nil);
ChunkPaint := True;
end;
end;
end;
sknNone:
begin
DrawEdge(ACanvas.Handle, ARect, BDR_SUNKENOUTER, BF_RECT);
if DrawProgress and not IsRectEmpty(DeltaR) then
if Smooth then begin
ACanvas.Brush.Color := clHighlight;
ACanvas.FillRect(DeltaR);
end
else begin
// Chunks are 10 x 13
if Vertical then begin
B.Width := DeltaR.Right - DeltaR.Left;
B.Height := 10;
R := Rect(0, 2, B.Width, B.Height);
end
else begin
B.Width := 10;
B.Height := DeltaR.Bottom - DeltaR.Top;
R := Rect(0, 0, B.Width - 2, B.Height);
end;
B.Canvas.Brush.Color := clBtnFace;
B.Canvas.FillRect(Rect(0, 0, B.Width, B.Height));
B.Canvas.Brush.Color := clHighlight;
B.Canvas.FillRect(R);
ChunkPaint := True;
end;
end;
sknSkin:
begin
CurrentSkin.PaintBackground(ACanvas, ARect, skncProgressBar, sknsNormal, True, True);
if DrawProgress and not IsRectEmpty(DeltaR) then begin
B.Width := ARect.Right - ARect.Left;
B.Height := ARect.Bottom - ARect.Top;
R := Rect(0, 0, B.Width, B.Height);
B.Canvas.CopyRect(R, ACanvas, ARect); // B is transparent
CurrentSkin.PaintBackground(B.Canvas, R, skncProgressBar, sknsHotTrack, True, True);
if Vertical then
R.Top := R.Bottom - (DeltaR.Bottom - DeltaR.Top)
else
R.Right := DeltaR.Right - DeltaR.Left;
ACanvas.CopyRect(DeltaR, B.Canvas, R);
end;
end;
end;
if ChunkPaint then begin
if Vertical then begin
ExcludeClipRect(ACanvas.Handle, ARect.Left, ARect.Top, ARect.Right, ARect.Top + 2);
I := DeltaR.Bottom - B.Height;
while I > DeltaR.Top - B.Height do begin
ACanvas.Draw(DeltaR.Left, I, B);
Dec(I, B.Height);
end;
end
else begin
ExcludeClipRect(ACanvas.Handle, ARect.Right - 2, ARect.Top, ARect.Right, ARect.Bottom);
I := DeltaR.Left;
while I < DeltaR.Right do begin
ACanvas.Draw(I, DeltaR.Top, B);
Inc(I, B.Width);
end;
end;
SelectClipRgn(ACanvas.Handle, 0);
end;
finally
B.Free;
end;
end;
procedure SpDrawXPTrackBar(ACanvas: TCanvas; ARect: TRect; Part: Cardinal;
Vertical, Pushed, ChannelSelection: Boolean; TickMark: TSpTBXTickMark;
Min, Max, SelStart, SelEnd: Integer; SkinType: TSpTBXSkinType);
var
Flags: Integer;
procedure DrawChannelSelection(ChannelR: TRect);
var
I: Integer;
Step : Single;
begin
if not ChannelSelection then Exit;
I := Max - Min;
if (I > 0) and (SelEnd > SelStart) then begin
if SkinType = sknSkin then
InflateRect(ChannelR, -2, -2)
else
InflateRect(ChannelR, -1, -1);
Step := (ChannelR.Right - ChannelR.Left) / I;
ChannelR.Right := ChannelR.Left + Round(SelEnd * Step);
ChannelR.Left := ChannelR.Left + Round(SelStart * Step);
if SkinType = sknSkin then
CurrentSkin.PaintBackground(ACanvas, ChannelR, skncTrackBar, sknsHotTrack, True, True)
else begin
ACanvas.Brush.Color := clHighlight;
ACanvas.FillRect(ChannelR);
end;
end;
end;
begin
SkinType := SpTBXSkinType(SkinType);
case SkinType of
sknWindows:
if Part = TBCD_THUMB then begin
if Pushed then Flags := TUS_HOT
else Flags := TUS_NORMAL;
Case TickMark of
tmxBottomRight:
if Vertical then Part := TKP_THUMBRIGHT
else Part := TKP_THUMBBOTTOM;
tmxTopLeft:
if Vertical then Part := TKP_THUMBLEFT
else Part := TKP_THUMBTOP;
tmxBoth, tmxCenter:
if Vertical then Part := TKP_THUMBVERT
else Part := TKP_THUMB;
end;
DrawThemeBackground(ThemeServices.Theme[teTrackBar], ACanvas.Handle, Part, Flags, ARect, nil);
end
else if Part = TBCD_CHANNEL then begin
if Vertical then Part := TKP_TRACKVERT
else Part := TKP_TRACK;
DrawThemeBackground(ThemeServices.Theme[teTrackBar], ACanvas.Handle, Part, TKS_NORMAL, ARect, nil);
DrawChannelSelection(ARect);
end;
sknNone:
if Part = TBCD_THUMB then begin
ACanvas.Brush.Color := clBtnFace;
ACanvas.FillRect(ARect);
DrawFrameControl(ACanvas.Handle, ARect, DFC_BUTTON, DFCS_BUTTONPUSH);
end
else if Part = TBCD_CHANNEL then begin
ACanvas.Brush.Color := clWindow;
ACanvas.FillRect(ARect);
ExtCtrls.Frame3D(ACanvas, ARect, clBtnShadow, clBtnHighlight, 1);
ExtCtrls.Frame3D(ACanvas, ARect, cl3DDkShadow, clBtnFace, 1);
DrawChannelSelection(ARect);
end;
sknSkin:
if Part = TBCD_THUMB then begin
if Pushed then
CurrentSkin.PaintBackground(ACanvas, ARect, skncTrackBarButton, sknsPushed, True, True)
else
CurrentSkin.PaintBackground(ACanvas, ARect, skncTrackBarButton, sknsNormal, True, True);
end
else if Part = TBCD_CHANNEL then begin
CurrentSkin.PaintBackground(ACanvas, ARect, skncTrackBar, sknsNormal, True, True);
DrawChannelSelection(ARect);
end;
end;
end;
procedure SpInvalidateSpTBXControl(AControl: TWinControl; InvalidateChildren, OnlySpTBXControls: Boolean);
var
I: Integer;
ChildW: TWinControl;
begin
// Invalidate will not fire WM_ERASEBKGND, because csOpaque is setted
if Assigned(AControl) and not (csDestroying in AControl.ComponentState) and AControl.HandleAllocated then
begin
if InvalidateChildren then begin
if OnlySpTBXControls then begin
RedrawWindow(AControl.Handle, nil, 0, RDW_ERASE or RDW_INVALIDATE);
// Only invalidate SpTBXControls
for I := 0 to AControl.ControlCount - 1 do
if Assigned(AControl.Controls[I]) and (AControl.Controls[I] is TWinControl) then begin
ChildW := AControl.Controls[I] as TWinControl;
if ChildW is TSpTBXTextObject then
RedrawWindow(ChildW.Handle, nil, 0, RDW_ERASE or RDW_INVALIDATE)
else
PostMessage(ChildW.Handle, CM_SPTBXCONTROLSINVALIDATE, ChildW.Width, ChildW.Height);
end;
end
else
RedrawWindow(AControl.Handle, nil, 0, RDW_ERASE or RDW_INVALIDATE or RDW_ALLCHILDREN);
end
else
RedrawWindow(AControl.Handle, nil, 0, RDW_ERASE or RDW_INVALIDATE);
end;
end;
procedure ApplyMargins(var R: TRect; const Margins: TRect); overload;
begin
with Margins do begin
Inc(R.Left, Left); Inc(R.Top, Top);
Dec(R.Right, Right); Dec(R.Bottom, Bottom);
end;
end;
function GetRealAlignment(Control: TControl): TAlignment;
const
ReverseAlignment: array [TAlignment] of TAlignment = (taRightJustify, taLeftJustify, taCenter);
begin
Result := Control.GetControlsAlignment;
if Control.UseRightToLeftAlignment then Result := ReverseAlignment[Result];
end;
//WMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWM
{ TSpTBXCustomPanel }
constructor TSpTBXCustomPanel.Create(AOwner: TComponent);
begin
inherited;
ControlStyle := ControlStyle + [csAcceptsControls];
FBackground := TBitmap.Create;
FBorders := True;
FBorderType := pbrEtched;
FSkinType := sknSkin;
Color := clNone;
ParentColor := False;
SkinManager.AddSkinNotification(Self);
end;
destructor TSpTBXCustomPanel.Destroy;
begin
FreeAndNil(FBackground);
SkinManager.RemoveSkinNotification(Self);
inherited;
end;
procedure TSpTBXCustomPanel.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params);
if not (csDesigning in ComponentState) then begin
with Params do
Style := Style or WS_CLIPCHILDREN;
with Params.WindowClass do
Style := Style and not (CS_HREDRAW or CS_VREDRAW);
end;
end;
procedure TSpTBXCustomPanel.AdjustClientRect(var Rect: TRect);
begin
inherited AdjustClientRect(Rect);
if Borders then
InflateRect(Rect, -2, -2);
end;
procedure TSpTBXCustomPanel.InvalidateBackground(InvalidateChildren: Boolean);
begin
// Force background repaint
if Assigned(FBackground) then
FBackground.Width := 1;
SpInvalidateSpTBXControl(Self, InvalidateChildren, True);
end;
procedure TSpTBXCustomPanel.SetBorders(const Value: Boolean);
begin
if FBorders <> Value then begin
FBorders := Value;
Realign;
InvalidateBackground;
end;
end;
procedure TSpTBXCustomPanel.SetBorderType(const Value: TSpTBXPanelBorder);
begin
if FBorderType <> Value then begin
FBorderType := Value;
InvalidateBackground;
end;
end;
procedure TSpTBXCustomPanel.SetSkinType(const Value: TSpTBXSkinType);
begin
if Value <> FSkinType then begin
FSkinType := Value;
InvalidateBackground(False);
end;
end;
procedure TSpTBXCustomPanel.SetTBXStyleBackground(const Value: Boolean);
begin
if FTBXStyleBackground <> Value then begin
FTBXStyleBackground := Value;
InvalidateBackground;
end;
end;
procedure TSpTBXCustomPanel.DoDrawBackground(ACanvas: TCanvas;
ARect: TRect; const PaintStage: TSpTBXPaintStage;
var PaintDefault: Boolean);
begin
if Assigned(FOnDrawBackground) then FOnDrawBackground(Self, ACanvas, ARect,
PaintStage, PaintDefault);
end;
procedure TSpTBXCustomPanel.DrawBackground(ACanvas: TCanvas; ARect: TRect);
begin
SpDrawXPPanel(ACanvas, ARect, True, FTBXStyleBackground, FSkinType, FBorderType);
end;
procedure TSpTBXCustomPanel.CMFontChanged(var Message: TMessage);
begin
inherited;
InvalidateBackground(False);
end;
procedure TSpTBXCustomPanel.CMSpTBXControlsInvalidate(var Message: TMessage);
begin
InvalidateBackground;
Message.Result := 1;
end;
procedure TSpTBXCustomPanel.WMEraseBkgnd(var Message: TMessage);
var
R, R2: TRect;
PaintDefault: Boolean;
ACanvas: TCanvas;
begin
Message.Result := 1;
if (not DoubleBuffered or (Message.wParam = Message.lParam)) and
not (csDestroying in ComponentState) and Assigned(FBackground) then
begin
ACanvas := TCanvas.Create;
try
ACanvas.Handle := TWMEraseBkgnd(Message).DC;
R := ClientRect;
if (FBackground.Width = R.Right) and (FBackground.Height = R.Bottom) and not Assigned(FOnDrawBackground) then
ACanvas.Draw(R.Left, R.Top, FBackground)
else begin
FBackground.Width := R.Right;
FBackground.Height := R.Bottom;
if (Color = clNone) and Assigned(Parent) then begin
// The Panel is a special component, it has the ability
// to paint the parent background on its children controls.
// For that it receives WM_ERASEBKGND messages from its children
// via SpDrawParentBackground.
SpDrawParentBackground(Self, FBackground.Canvas.Handle, R);
// PerformEraseBackground(Self, FBackground.Canvas.Handle);
end
else
Windows.FillRect(FBackground.Canvas.Handle, ClientRect, Brush.Handle);
// Set the Font after SpDrawParentBackground, DrawThemeParentBackground,
// or PerformEraseBackground.
// The API messes the font, it seems it destroys it.
// For more info see:
// - TCustomActionControl.DrawBackground for more info.
// - Theme Explorer Main.pas TMainForm.ControlMessage
// (http://www.soft-gems.net:8080/browse/Demos)
FBackground.Canvas.Font.Handle := 0; // Reset the font, it gets destroyed
FBackground.Canvas.Font.Color := $010101; // Force a change
FBackground.Canvas.Font.Assign(Self.Font);
PaintDefault := True;
DoDrawBackground(FBackground.Canvas, R, pstPrePaint, PaintDefault);
if PaintDefault then begin
if not FBorders then begin
R2 := R;
InflateRect(R2, 3, 3);
DrawBackground(FBackground.Canvas, R2);
end
else
DrawBackground(FBackground.Canvas, R);
end;
PaintDefault := True;
DoDrawBackground(FBackground.Canvas, R, pstPostPaint, PaintDefault);
ACanvas.Draw(R.Left, R.Top, FBackground);
end;
finally
ACanvas.Handle := 0;
ACanvas.Free;
end;
end;
end;
procedure TSpTBXCustomPanel.WMWindowPosChanged(var Message: TWMWindowPosChanged);
begin
inherited;
InvalidateBackground;
end;
procedure TSpTBXCustomPanel.WMSpSkinChange(var Message: TMessage);
begin
InvalidateBackground;
end;
//WMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWM
{ TSpTBXPanel }
procedure TSpTBXPanel.DrawBackground(ACanvas: TCanvas; ARect: TRect);
begin
if not TBXStyleBackground and FHotTrack then begin
if SpTBXSkinType(SkinType) = sknNone then
SpDrawXPPanelBorder(ACanvas, ARect, pbrDoubleSunken)
else
SpDrawXPEditFrame(ACanvas, ARect, Enabled, FHotTracking, SkinType, True, True);
end
else
inherited;
end;
procedure TSpTBXPanel.CMFocusChanged(var Message: TCMFocusChanged);
begin
inherited;
if FHotTrack and Assigned(Message.Sender) then begin
FChildFocused := SpFindControl(Self, Message.Sender) > -1;
if FChildFocused <> FHotTracking then
SetHotTracking(FChildFocused);
end;
end;
procedure TSpTBXPanel.CMMouseEnter(var Message: TMessage);
begin
inherited;
if FHotTrack and not FHotTracking then
SetHotTracking(True);
end;
procedure TSpTBXPanel.CMMouseLeave(var Message: TMessage);
begin
inherited;
if FHotTrack and FHotTracking and not FChildFocused then
SetHotTracking(False);
end;
procedure TSpTBXPanel.SetHotTrack(const Value: Boolean);
begin
if FHotTrack <> Value then begin
FHotTrack := Value;
InvalidateBackground(False);
end;
end;
procedure TSpTBXPanel.SetHotTracking(const Value: Boolean);
begin
if SpTBXSkinType(SkinType) = sknSkin then begin
FHotTracking := Value;
InvalidateBackground(False);
end;
end;
//WMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWM
{ TSpTBXCustomGroupBox }
constructor TSpTBXCustomGroupBox.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
ControlStyle := ControlStyle + [csSetCaption];
Width := 185;
Height := 105;
end;
procedure TSpTBXCustomGroupBox.AdjustClientRect(var Rect: TRect);
var
R: TRect;
H: Integer;
begin
inherited AdjustClientRect(Rect);
Canvas.Font := Font;
R := Rect;
H := SpDrawXPText(Canvas, '0', R, DT_SINGLELINE or DT_CALCRECT);
Inc(Rect.Top, H);
end;
procedure TSpTBXCustomGroupBox.CMDialogChar(var Message: TCMDialogChar);
begin
with Message do
if IsAccel(CharCode, Caption) and SpCanFocus(Self) then begin
SelectFirst;
Result := 1;
end
else
inherited;
end;
procedure TSpTBXCustomGroupBox.CMTextChanged(var Message: TMessage);
begin
inherited;
InvalidateBackground(False);
Realign;
end;
procedure TSpTBXCustomGroupBox.DrawBackground(ACanvas: TCanvas; ARect: TRect);
var
Flags: Cardinal;
begin
Flags := DT_SINGLELINE;
if UseRightToLeftAlignment then
Flags := Flags or DT_RTLREADING;
SpDrawXPGroupBox(ACanvas, ARect, Caption, Flags, True, TBXStyleBackground, SkinType);
end;
//WMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWM
{ TSpTBXTextObjectActionLink }
{$IFNDEF UNICODE}
procedure TSpTBXTextObjectActionLink.AssignClient(AClient: TObject);
begin
inherited AssignClient(AClient);
FUnicodeClient := AClient as TSpTBXTextObject;
end;
function TSpTBXTextObjectActionLink.IsCheckedLinked: Boolean;
begin
Result := inherited IsCheckedLinked and
(FUnicodeClient.Checked = (Action as TCustomAction).Checked);
end;
function TSpTBXTextObjectActionLink.IsCaptionLinked: Boolean;
begin
if (Action is TCustomAction) and Supports(Action, ITntAction) then
Result := FUnicodeClient.Caption = TntActnList.TntAction_GetCaption(Action as TCustomAction)
else
Result := inherited IsCaptionLinked;
end;
function TSpTBXTextObjectActionLink.IsHintLinked: Boolean;
begin
if (Action is TCustomAction) and Supports(Action, ITntAction) then
Result := FUnicodeClient.Hint = TntActnList.TntAction_GetHint(Action as TCustomAction)
else
Result := inherited IsHintLinked;
end;
procedure TSpTBXTextObjectActionLink.SetCaption(const Value: String);
begin
if IsCaptionLinked then
if (Action is TCustomAction) and Supports(Action, ITntAction) then
FUnicodeClient.Caption := TntActnList.TntAction_GetNewCaption(Action as TCustomAction, Value)
else
FUnicodeClient.Caption := Value;
end;
procedure TSpTBXTextObjectActionLink.SetChecked(Value: Boolean);
begin
if IsCheckedLinked then FUnicodeClient.Checked := Value;
end;
procedure TSpTBXTextObjectActionLink.SetHint(const Value: String);
begin
if IsHintLinked then
if (Action is TCustomAction) and Supports(Action, ITntAction) then
FUnicodeClient.Hint := TntActnList.TntAction_GetNewHint(Action as TCustomAction, Value)
else
FUnicodeClient.Hint := Value;
end;
procedure TSpTBXTextObjectActionLink.SetImageIndex(Value: Integer);
begin
if IsImageIndexLinked then FUnicodeClient.ImageIndex := Value;
end;
{$ENDIF}
//WMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWM
{ TSpTBXTextObject }
constructor TSpTBXTextObject.Create(AOwner: TComponent);
begin
inherited;
ControlStyle := ControlStyle + [csClickEvents, csDoubleClicks, csSetCaption] - [csAcceptsControls, csOpaque];
FImageIndex := -1;
FImageChangeLink := TChangeLink.Create;
FImageChangeLink.OnChange := ImageListChange;
FAlignment := taLeftJustify;
FCaptionGlowColor := clYellow;
FDisabledIconCorrection := True;
FDrawPushedCaption := False;
FShowAccelChar := True;
FSkinType := sknSkin;
Autosize := True;
Color := clNone;
DoubleBuffered := True;
ParentColor := False;
TabStop := True;
Width := 100;
SkinManager.AddSkinNotification(Self);
end;
destructor TSpTBXTextObject.Destroy;
begin
FImageChangeLink.Free;
SkinManager.RemoveSkinNotification(Self);
inherited;
end;
procedure TSpTBXTextObject.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params);
{
if not (csDesigning in ComponentState) then
with Params.WindowClass do
Style := Style and not (CS_HREDRAW or CS_VREDRAW);
}
end;
procedure TSpTBXTextObject.Notification(AComponent: TComponent; Operation: TOperation);
begin
inherited;
if Operation = opRemove then
if AComponent = Images then SetImages(nil);
end;
procedure TSpTBXTextObject.DefineProperties(Filer: TFiler);
begin
inherited;
// [Backward-Compatibility]: Don't read/save LinkFont, it's not used anymore
Filer.DefineProperty('LinkFont.Charset', ReadLinkFont, nil, False);
Filer.DefineProperty('LinkFont.Color', ReadLinkFont, nil, False);
Filer.DefineProperty('LinkFont.Height', ReadLinkFont, nil, False);
Filer.DefineProperty('LinkFont.Name', ReadLinkFont, nil, False);
Filer.DefineProperty('LinkFont.Orientation', ReadLinkFont, nil, False);
Filer.DefineProperty('LinkFont.Pitch', ReadLinkFont, nil, False);
Filer.DefineProperty('LinkFont.Style', ReadLinkFont, nil, False);
Filer.DefineProperty('EditButton.LinkFont.Charset', ReadLinkFont, nil, False);
Filer.DefineProperty('EditButton.LinkFont.Color', ReadLinkFont, nil, False);
Filer.DefineProperty('EditButton.LinkFont.Height', ReadLinkFont, nil, False);
Filer.DefineProperty('EditButton.LinkFont.Name', ReadLinkFont, nil, False);
Filer.DefineProperty('EditButton.LinkFont.Orientation', ReadLinkFont, nil, False);
Filer.DefineProperty('EditButton.LinkFont.Pitch', ReadLinkFont, nil, False);
Filer.DefineProperty('EditButton.LinkFont.Style', ReadLinkFont, nil, False);
Filer.DefineProperty('SpinButton.LinkFont.Charset', ReadLinkFont, nil, False);
Filer.DefineProperty('SpinButton.LinkFont.Color', ReadLinkFont, nil, False);
Filer.DefineProperty('SpinButton.LinkFont.Height', ReadLinkFont, nil, False);
Filer.DefineProperty('SpinButton.LinkFont.Name', ReadLinkFont, nil, False);
Filer.DefineProperty('SpinButton.LinkFont.Orientation', ReadLinkFont, nil, False);
Filer.DefineProperty('SpinButton.LinkFont.Pitch', ReadLinkFont, nil, False);
Filer.DefineProperty('SpinButton.LinkFont.Style', ReadLinkFont, nil, False);
end;
function TSpTBXTextObject.GetActionLinkClass: TControlActionLinkClass;
begin
Result := TSpTBXTextObjectActionLink;
end;
procedure TSpTBXTextObject.ActionChange(Sender: TObject; CheckDefaults: Boolean);
begin
inherited;
if Sender is TCustomAction then
with TCustomAction(Sender) do begin
if not CheckDefaults or (Self.Checked = False) then
Self.Checked := Checked;
if not CheckDefaults or (Self.ImageIndex = -1) then
Self.ImageIndex := ImageIndex;
end;
end;
procedure TSpTBXTextObject.AdjustFont(AFont: TFont);
begin
if (FLinkText <> '') and MouseInControl then begin
AFont.Color := clBlue;
AFont.Style := AFont.Style + [fsUnderline];
end;
end;
procedure TSpTBXTextObject.AdjustBounds;
var
NewWidth, NewHeight: Integer;
begin
if HandleAllocated and not FUpdating and ([csReading, csLoading] * ComponentState = []) and AutoSize then
begin
FUpdating := True;
try
NewWidth := Width;
NewHeight := 0;
DoAdjustBounds(NewWidth, NewHeight);
SetBounds(Left, Top, NewWidth, NewHeight);
finally
FUpdating := False;
end;
end;
end;
function TSpTBXTextObject.CanFocus: Boolean;
begin
Result := False;
end;
procedure TSpTBXTextObject.Click;
begin
if not (csLoading in ComponentState) then begin
Invalidate;
inherited;
ExecuteLink;
end;
end;
function TSpTBXTextObject.CanAutoSize(var NewWidth, NewHeight: Integer): Boolean;
begin
if not FUpdating and ([csReading, csLoading] * ComponentState = []) and AutoSize then begin
FUpdating := True;
try
NewHeight := 0;
DoAdjustBounds(NewWidth, NewHeight);
Result := True;
finally
FUpdating := False;
end;
end
else
Result := False;
end;
procedure TSpTBXTextObject.DoAdjustBounds(var NewWidth, NewHeight: Integer);
var
R, R1, R2: TRect;
begin
GetSize(R, R1, R2);
NewHeight := R.Bottom - R.Top;
if Wrapping = twNone then
NewWidth := R.Right - R.Left;
end;
procedure TSpTBXTextObject.DoDrawHint(AHintBitmap: TBitmap;
var AHint: Widestring; var PaintDefault: Boolean);
begin
if Assigned(FOnDrawHint) then FOnDrawHint(Self, AHintBitmap, AHint, PaintDefault);
end;
function TSpTBXTextObject.DoDrawItem(ACanvas: TCanvas; ARect: TRect;
const PaintStage: TSpTBXPaintStage): Boolean;
begin
Result := True;
if Assigned(FOnDraw) then FOnDraw(Self, ACanvas, ARect, PaintStage, Result);
end;
function TSpTBXTextObject.DoDrawText(ACanvas: TCanvas; var ARect: TRect;
Flags: Longint): Integer;
var
PaintDefault: Boolean;
GlyphSize, DummyRightGlyphSize: TSize;
DummyRightGlyphRect: TRect;
R, R1, R2: TRect;
WS: WideString;
TextFlags: Cardinal;
State: TSpTBXSkinStatesType;
begin
Result := 0;
WS := Caption;
TextFlags := Flags;
if TextFlags and DT_CALCRECT = 0 then begin
ACanvas.Brush.Style := bsClear;
State := CurrentSkin.GetState(Enabled, Pushed, MouseInControl, Checked);
PaintDefault := True;
if Assigned(FOnDrawCaption) then
FOnDrawCaption(Self, ACanvas, ClientRect, State, WS, ARect, TextFlags, False, pstPrePaint, PaintDefault);
if PaintDefault then begin
// Calc the rects
GlyphSize := GetGlyphSize;
DummyRightGlyphSize.cx := 0;
DummyRightGlyphSize.cy := 0;
DummyRightGlyphRect := Rect(0, 0, 0, 0);
SpCalcXPText(ACanvas, ARect, WS, GetRealAlignment(Self), TextFlags, GlyphSize, DummyRightGlyphSize, FGlyphLayout, DrawPushedCaption and Pushed, R1, R2, DummyRightGlyphRect, FCaptionRoatationAngle);
// Paint the text
if not Enabled then
if SpTBXSkinType(FSkinType) = sknNone then begin
OffsetRect(R1, 1, 1);
ACanvas.Font.Color := clBtnHighlight;
SpDrawXPText(ACanvas, WS, R1, TextFlags, FCaptionGlow, FCaptionGlowColor, FCaptionRoatationAngle);
OffsetRect(R1, -1, -1);
ACanvas.Font.Color := clGrayText;
end;
SpDrawXPText(ACanvas, WS, R1, TextFlags, FCaptionGlow, FCaptionGlowColor, FCaptionRoatationAngle);
// Paint the glyph
DoInternalGlyphDraw(ACanvas, R2);
end;
PaintDefault := True;
if Assigned(FOnDrawCaption) then
FOnDrawCaption(Self, ACanvas, ClientRect, State, WS, ARect, TextFlags, False, pstPostPaint, PaintDefault);
if PaintDefault then
if GetFocused then begin
R := ClientRect;
SpDrawFocusRect(ACanvas, GetFocusRect(R, R1, R2));
end;
end
else
Result := SpDrawXPText(ACanvas, WS, ARect, TextFlags);
end;
procedure TSpTBXTextObject.DoGetImageIndex(var AImageList: TCustomImageList; var AImageIndex: Integer);
begin
if Assigned(FOnGetImageIndex) then FOnGetImageIndex(Self, AImageList, AImageIndex);
end;
procedure TSpTBXTextObject.DoInternalGlyphDraw(ACanvas: TCanvas;
AGlyphRect: TRect);
var
I: Integer;
IL: TCustomImageList;
begin
IL := FImages;
I := FImageIndex;
DoGetImageIndex(IL, I);
if Assigned(IL) and (I > -1) and (I < IL.Count) then
SpDrawImageList(ACanvas, AGlyphRect, IL, I, Enabled, FDisabledIconCorrection)
end;
procedure TSpTBXTextObject.DoMouseEnter;
begin
Invalidate;
if Assigned(FOnMouseEnter) then FOnMouseEnter(Self);
end;
procedure TSpTBXTextObject.DoMouseLeave;
begin
Invalidate;
if Assigned(FOnMouseLeave) then FOnMouseLeave(Self);
end;
procedure TSpTBXTextObject.ExecuteLink;
begin
if FLinkText <> '' then
if Win32Platform = VER_PLATFORM_WIN32_WINDOWS then
ShellExecuteA(Application.Handle, 'open', PAnsiChar(AnsiString(FLinkText)), PAnsiChar(AnsiString(FLinkTextParams)), '', SW_SHOWNORMAL)
else
ShellExecuteW(Application.Handle, 'open', PWideChar(FLinkText), PWideChar(FLinkTextParams), '', SW_SHOWNORMAL);
end;
function TSpTBXTextObject.GetControlsAlignment: TAlignment;
begin
Result := FAlignment;
end;
function TSpTBXTextObject.GetTextFlags: Cardinal;
const
Alignments: array [TAlignment] of Integer = (DT_LEFT, DT_RIGHT, DT_CENTER);
WordWraps: array [TTextWrapping] of Integer = (DT_SINGLELINE,
DT_SINGLELINE or DT_END_ELLIPSIS,
DT_SINGLELINE or DT_PATH_ELLIPSIS, DT_WORDBREAK);
ShowAccelChars: array [Boolean] of Integer = (DT_NOPREFIX, 0);
SystemAccelChars: array [Boolean] of Integer = (DT_HIDEPREFIX, 0);
begin
// Note on SystemAccelChars: custom controls need to update the accel painting
// in response to WM_UPDATEUISTATE, call WM_QUERYUISTATE to get the accel
// painting state:
// http://blogs.msdn.com/oldnewthing/archive/2005/05/03/414317.aspx
//
// Another way of doing it is updating a flag in WM_UPDATEUISTATE, without
// calling WM_QUERYUISTATE everytime the control needs to be painted:
// begin
// if LoWord(Message.WParam) and UISF_HIDEACCEL = UISF_HIDEACCEL then begin
// if HiWord(Message.WParam) and UIS_CLEAR = UIS_CLEAR then
// FSystemShowAccelChar := True;
// if HiWord(Message.WParam) and UIS_SET = UIS_SET then
// FSystemShowAccelChar := False;
// end;
// inherited;
// end;
//
// To test this use the mouse to run the app on the IDE, don't use F9
// otherwise the accel will always be visible
Result := DT_EXPANDTABS or WordWraps[Wrapping] or
Alignments[GetRealAlignment(Self)] or
ShowAccelChars[ShowAccelChar] or SystemAccelChars[SendMessage(Handle, WM_QUERYUISTATE, 0, 0) and UISF_HIDEACCEL = 0];
Result := DrawTextBiDiModeFlags(Result);
end;
function TSpTBXTextObject.GetFocusRect(R, TextR, GlyphR: TRect): TRect;
begin
if Caption = '' then
Result := Rect(0, 0, 0, 0)
else begin
InflateRect(TextR, 1, 1);
Result := TextR;
end;
end;
function TSpTBXTextObject.GetGlyphSize: TSize;
var
I: Integer;
IL: TCustomImageList;
begin
IL := FImages;
I := FImageIndex;
DoGetImageIndex(IL, I);
if Assigned(IL) and (I > -1) and (I < IL.Count) then begin
Result.cx := IL.Width;
Result.cy := IL.Height;
end
else begin
Result.cx := 0;
Result.cy := 0;
end;
end;
function TSpTBXTextObject.GetFocused: Boolean;
begin
Result := Focused;
end;
function TSpTBXTextObject.GetPushed: Boolean;
begin
Result := FPushed and MouseInControl;
end;
procedure TSpTBXTextObject.GetSize(out TotalR, TextR, GlyphR: TRect);
// Size of Text + Glyph + TextMargin + Margins
var
GlyphSize, DummyRightGlyphSize: TSize;
DummyRightGlyphRect: TRect;
R: TRect;
begin
GlyphSize := GetGlyphSize;
DummyRightGlyphSize.cx := 0;
DummyRightGlyphSize.cy := 0;
DummyRightGlyphRect := Rect(0, 0, 0, 0);
R := ClientRect;
ApplyMargins(R, GetTextMargins);
Canvas.Font.Assign(Font);
AdjustFont(Canvas.Font);
SpCalcXPText(Canvas, R, Caption, GetRealAlignment(Self), GetTextFlags, GlyphSize, DummyRightGlyphSize,
FGlyphLayout, DrawPushedCaption and Pushed, TextR, GlyphR, DummyRightGlyphRect);
UnionRect(TotalR, TextR, GlyphR);
{$IF CompilerVersion > 17}
if Autosize then
with Margins do begin
Inc(TotalR.Right, Left + Right);
Inc(TotalR.Bottom, Top + Bottom);
end;
{$IFEND}
end;
function TSpTBXTextObject.GetTextMargins: TRect;
begin
Result := Rect(0, 0, 0, 0);
end;
procedure TSpTBXTextObject.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
if (Button = mbLeft) and Enabled and not FPushed then begin
FPushed := True;
if not Focused and CanFocus then
SetFocus // Invalidates the canvas
else
Invalidate;
end;
inherited;
end;
procedure TSpTBXTextObject.MouseMove(Shift: TShiftState; X, Y: Integer);
begin
if FPushed then
UpdateTracking;
inherited;
end;
procedure TSpTBXTextObject.MouseUp(Button: TMouseButton; Shift: TShiftState; X,
Y: Integer);
begin
FPushed := False;
Invalidate;
inherited;
end;
procedure TSpTBXTextObject.KeyDown(var Key: Word; Shift: TShiftState);
begin
inherited;
if (Key = VK_SPACE) and FSpaceAsClick then begin
FPushed := True;
FMouseInControl := True;
Invalidate;
end;
end;
procedure TSpTBXTextObject.KeyUp(var Key: Word; Shift: TShiftState);
begin
if (Key = VK_SPACE) and FSpaceAsClick and FPushed then begin
FPushed := False;
FMouseInControl := False;
Click;
Invalidate;
end;
inherited;
end;
procedure TSpTBXTextObject.Paint;
var
R, TextR: TRect;
begin
R := ClientRect;
Canvas.Font.Assign(Font);
AdjustFont(Canvas.Font);
// Draw the background
DoDrawItem(Canvas, R, pstPrePaint);
// Draw the text
TextR := R;
ApplyMargins(TextR, GetTextMargins);
DoDrawText(Canvas, TextR, GetTextFlags);
// Draw the Focus, Icon and Text
DoDrawItem(Canvas, R, pstPostPaint);
end;
procedure TSpTBXTextObject.ReadLinkFont(Reader: TReader);
begin
// [Backward-Compatibility]
Reader.SkipValue;
end;
procedure TSpTBXTextObject.SetAlignment(const Value: TAlignment);
begin
if FAlignment <> Value then begin
FAlignment := Value;
Invalidate;
end;
end;
procedure TSpTBXTextObject.Loaded;
begin
inherited;
AdjustBounds;
end;
procedure TSpTBXTextObject.SetCaptionGlow(const Value: TSpGlowDirection);
begin
if FCaptionGlow <> Value then begin
FCaptionGlow := Value;
Invalidate;
end;
end;
procedure TSpTBXTextObject.SetCaptionGlowColor(const Value: TColor);
begin
if FCaptionGlowColor <> Value then begin
FCaptionGlowColor := Value;
Invalidate;
end;
end;
procedure TSpTBXTextObject.SetCaptionRoatationAngle(const Value: TSpTextRotationAngle);
begin
if FCaptionRoatationAngle <> Value then begin
FCaptionRoatationAngle := Value;
Invalidate;
end;
end;
function TSpTBXTextObject.GetChecked: Boolean;
begin
Result := FChecked;
end;
procedure TSpTBXTextObject.SetChecked(Value: Boolean);
begin
if Value <> FChecked then begin
FChecked := Value;
Invalidate;
end;
end;
procedure TSpTBXTextObject.SetGlyphLayout(const Value: TSpGlyphLayout);
begin
if FGlyphLayout <> Value then begin
FGlyphLayout := Value;
Invalidate;
end;
end;
function TSpTBXTextObject.IsImageIndexValid: Boolean;
var
I: Integer;
IL: TCustomImageList;
begin
IL := FImages;
I := FImageIndex;
DoGetImageIndex(IL, I);
Result := Assigned(IL) and (I > -1) and (I < IL.Count);
end;
procedure TSpTBXTextObject.ImageListChange(Sender: TObject);
begin
if Sender = Images then begin
Invalidate;
AdjustBounds;
end;
end;
procedure TSpTBXTextObject.SetImageIndex(const Value: TImageIndex);
begin
if FImageIndex <> Value then begin
FImageIndex := Value;
if Assigned(Images) then Invalidate;
AdjustBounds;
end;
end;
procedure TSpTBXTextObject.SetImages(const Value: TCustomImageList);
begin
if FImages <> nil then FImages.UnRegisterChanges(FImageChangeLink);
FImages := Value;
if FImages <> nil then begin
FImages.RegisterChanges(FImageChangeLink);
FImages.FreeNotification(Self);
end;
Invalidate;
AdjustBounds;
end;
procedure TSpTBXTextObject.SetShowAccelChar(Value: Boolean);
begin
if FShowAccelChar <> Value then begin
FShowAccelChar := Value;
AdjustBounds;
Invalidate;
end;
end;
procedure TSpTBXTextObject.SetSkinType(const Value: TSpTBXSkinType);
begin
if FSkinType <> Value then begin
FSkinType := Value;
Invalidate;
end;
end;
procedure TSpTBXTextObject.SetWrapping(Value: TTextWrapping);
begin
if FWrapping <> Value then begin
FWrapping := Value;
AdjustBounds;
Invalidate;
end;
end;
procedure TSpTBXTextObject.UpdateTracking(ForceMouseLeave: Boolean = False);
var
P: TPoint;
IsInControl: Boolean;
begin
if ForceMouseLeave then begin
FMouseInControl := True;
Perform(CM_MOUSELEAVE, 0, 0)
end
else
if Enabled then begin
GetCursorPos(P);
IsInControl := FindDragTarget(P, True) = Self;
if FMouseInControl <> IsInControl then begin
FMouseInControl := not IsInControl;
if FMouseInControl then
Perform(CM_MOUSELEAVE, 0, 0)
else
Perform(CM_MOUSEENTER, 0, 0);
end;
end;
end;
procedure TSpTBXTextObject.CMEnabledChanged(var Message: TMessage);
begin
inherited;
if not Enabled and FMouseInControl then begin
FMouseInControl := False;
DoMouseLeave;
Perform(WM_CANCELMODE, 0, 0);
end
else
Invalidate;
end;
procedure TSpTBXTextObject.CMFontChanged(var Message: TMessage);
begin
inherited;
Invalidate;
AdjustBounds;
end;
procedure TSpTBXTextObject.CMHintShow(var Message: TCMHintShow);
// Handle the CM_HINTSHOW message to show unicode hints using
// a custom THintWindow.
var
HintInfo: PHintInfo;
WideHint, PrevWideHint: Widestring;
R, TextR: TRect;
PaintDefault: Boolean;
I: Integer;
begin
// Get the short hint
I := Pos('|', Hint);
if I = 0 then
WideHint := Hint
else
WideHint := Copy(Hint, 1, I - 1);
// Prepare the HintBitmap
SpStockHintBitmap.Canvas.Font.Assign(Screen.HintFont);
SpStockHintBitmap.Canvas.Font.Color := clInfoText;
SpStockHintBitmap.Canvas.Pen.Color := clBlack;
SpStockHintBitmap.Canvas.Brush.Color := clInfoBk;
TextR := Rect(0, 0, 1, 1);
SpDrawXPText(SpStockHintBitmap.Canvas, WideHint, TextR, DT_NOPREFIX or DT_CALCRECT);
SpStockHintBitmap.Width := TextR.Right + 8;
SpStockHintBitmap.Height := TextR.Bottom + 4;
R := Rect(0, 0, SpStockHintBitmap.Width, SpStockHintBitmap.Height);
SpDrawXPTooltipBackground(SpStockHintBitmap.Canvas, R);
// Draw the hint in the HintBitmap
PrevWideHint := WideHint;
PaintDefault := True;
DoDrawHint(SpStockHintBitmap, WideHint, PaintDefault);
if PaintDefault then begin
// Prepare the HintInfo
HintInfo := Message.HintInfo;
HintInfo.HintStr := WideHint;
HintInfo.CursorRect := ClientRect;
HintInfo.HintWindowClass := SpTBXHintWindowClass; // Custom HintWindow class
HintInfo.HintData := SpStockHintBitmap; // TApplication.ActivateHint will pass the data to the HintWindow
HintInfo.HideTimeout := 60000; // 1 minute
// Adjust the bounds and repaint the background if it's needed
if WideHint <> PrevWideHint then begin
TextR := Rect(0, 0, 1, 1);
SpDrawXPText(SpStockHintBitmap.Canvas, WideHint, TextR, DT_NOPREFIX or DT_CALCRECT);
SpStockHintBitmap.Width := TextR.Right + 8;
SpStockHintBitmap.Height := TextR.Bottom + 4;
R := Rect(0, 0, SpStockHintBitmap.Width, SpStockHintBitmap.Height);
SpDrawXPTooltipBackground(SpStockHintBitmap.Canvas, R);
end
else
R := Rect(0, 0, SpStockHintBitmap.Width, SpStockHintBitmap.Height);
// Draw the hint
OffsetRect(TextR, ((R.Right - TextR.Right) div 2) - 2, (R.Bottom - TextR.Bottom) div 2);
SpDrawXPText(SpStockHintBitmap.Canvas, WideHint, TextR, DT_NOPREFIX);
end;
end;
procedure TSpTBXTextObject.CMMouseEnter(var Message: TMessage);
begin
inherited;
if not FMouseInControl then begin
FMouseInControl := True;
DoMouseEnter;
end;
end;
procedure TSpTBXTextObject.CMMouseLeave(var Message: TMessage);
begin
inherited;
if FMouseInControl then begin
FMouseInControl := False;
DoMouseLeave;
end;
end;
procedure TSpTBXTextObject.CMTextChanged(var Message: TMessage);
begin
inherited;
Invalidate;
AdjustBounds;
end;
procedure TSpTBXTextObject.WMEraseBkgnd(var Message: TMessage);
begin
if not DoubleBuffered or (Message.wParam = Message.lParam) then
begin
if (Color = clNone) and Assigned(Parent) then
SpDrawParentBackground(Self, TWMEraseBkgnd(Message).DC, ClientRect)
else
Windows.FillRect(TWMEraseBkgnd(Message).DC, ClientRect, Brush.Handle);
end;
Message.Result := 1;
end;
procedure TSpTBXTextObject.WMKillFocus(var Message: TMessage);
begin
inherited;
FPushed := False;
Invalidate;
end;
procedure TSpTBXTextObject.WMSetFocus(var Message: TMessage);
begin
inherited;
Invalidate;
end;
procedure TSpTBXTextObject.WMSetCursor(var Message: TWMSetCursor);
begin
if not (csDesigning in ComponentState) and (Message.CursorWnd = Handle) and
(FLinkText <> '') and MouseInControl and (Screen.Cursor = crDefault) then
begin
// Replace the Delphi hand cursor for the one used by Windows only if
// there is no other cursor assigned.
Windows.SetCursor(Screen.Cursors[crSpTBXNewHandPoint]);
Message.Result := 1;
end
else
inherited;
end;
procedure TSpTBXTextObject.WMSpSkinChange(var Message: TMessage);
var
R: TRect;
begin
if HandleAllocated then begin
R := ClientRect;
InvalidateRect(Handle, @R, True);
end;
end;
//WMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWM
{ TSpTBXCustomLabel }
constructor TSpTBXCustomLabel.Create(AOwner: TComponent);
begin
inherited;
FUnderlineColor := clBtnShadow;
TabStop := False;
end;
procedure TSpTBXCustomLabel.AdjustFont(AFont: TFont);
var
State: TSpTBXSkinStatesType;
begin
if (LinkText <> '') and MouseInControl then
inherited
else
if (SkinType = sknSkin) and ((AFont.Color = clWindowText) or (AFont.Color = clNone)) then begin
State := CurrentSkin.GetState(Enabled, Pushed, MouseInControl, Checked);
AFont.Color := CurrentSkin.GetTextColor(skncLabel, State);
end;
end;
function TSpTBXCustomLabel.DoDrawItem(ACanvas: TCanvas; ARect: TRect;
const PaintStage: TSpTBXPaintStage): Boolean;
var
C: TColor;
begin
Result := inherited DoDrawItem(ACanvas, ARect, PaintStage);
if Result and (PaintStage = pstPrePaint) and FUnderline then begin
C := ACanvas.Pen.Color;
try
ACanvas.Pen.Color := UnderlineColor;
ACanvas.MoveTo(ARect.Left, ARect.Bottom - 1);
ACanvas.LineTo(ARect.Right, ARect.Bottom - 1);
finally
ACanvas.Pen.Color := C;
end;
end;
end;
procedure TSpTBXCustomLabel.GetSize(out TotalR, TextR, GlyphR: TRect);
begin
inherited GetSize(TotalR, TextR, GlyphR);
if FUnderline then
Inc(TotalR.Bottom);
end;
procedure TSpTBXCustomLabel.Notification(AComponent: TComponent;
Operation: TOperation);
begin
inherited;
if Operation = opRemove then
if AComponent = FocusControl then SetFocusControl(nil);
end;
procedure TSpTBXCustomLabel.SetFocusControl(const Value: TWinControl);
begin
if FFocusControl <> Value then
begin
FFocusControl := Value;
if FFocusControl <> nil then FFocusControl.FreeNotification(Self);
end;
end;
procedure TSpTBXCustomLabel.SetUnderline(const Value: Boolean);
begin
if Value <> FUnderline then begin
FUnderline := Value;
Invalidate;
AdjustBounds;
end;
end;
procedure TSpTBXCustomLabel.SetUnderlineColor(const Value: TColor);
begin
FUnderlineColor := Value;
Invalidate;
end;
procedure TSpTBXCustomLabel.CMDialogChar(var Message: TCMDialogChar);
begin
if Enabled and IsAccel(Message.CharCode, Caption) then begin
if SpCanFocus(FFocusControl) then
FFocusControl.SetFocus
else
Click;
Message.Result := 1;
end
else
inherited;
end;
//WMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWM
{ TSpTBXButtonControl }
constructor TSpTBXButtonControl.Create(AOwner: TComponent);
begin
inherited;
ControlStyle := ControlStyle - [csDoubleClicks];
FGroupIndex := 0;
end;
function TSpTBXButtonControl.CanFocus: Boolean;
var
Control: TWinControl;
Form: TCustomForm;
begin
Result := False;
Form := GetParentForm(Self);
if (Form <> nil) and Form.Visible and Form.Enabled then begin
Control := Self;
while Control <> Form do
begin
if not (Control.Visible and Control.Enabled) then Exit;
Control := Control.Parent;
end;
Result := True;
end;
end;
function TSpTBXButtonControl.CanUpdateExclusive: Boolean;
begin
Result := FGroupIndex <> 0;
end;
procedure TSpTBXButtonControl.UpdateExclusive;
var
Msg: TMessage;
begin
if Assigned(Parent) and CanUpdateExclusive then begin
Msg.Msg := CM_SPGROUPINDEXUPDATE;
Msg.WParam := FGroupIndex;
Msg.LParam := Longint(Self);
Msg.Result := 0;
Parent.Broadcast(Msg);
end;
end;
procedure TSpTBXButtonControl.SetGroupIndex(const Value: Integer);
begin
if FGroupIndex <> Value then begin
FGroupIndex := Value;
UpdateExclusive;
end;
end;
procedure TSpTBXButtonControl.SetAllowAllUp(const Value: Boolean);
begin
if FAllowAllUp <> Value then begin
FAllowAllUp := Value;
UpdateExclusive;
end;
end;
procedure TSpTBXButtonControl.SetChecked(Value: Boolean);
begin
inherited;
if Value then UpdateExclusive;
end;
procedure TSpTBXButtonControl.CMDialogChar(var Message: TCMDialogChar);
begin
if Enabled and ShowAccelChar and IsAccel(Message.CharCode, Caption) and
CanFocus and Visible then
begin
SetFocus;
Click;
Message.Result := 1;
end
else
inherited;
end;
procedure TSpTBXButtonControl.CMSPGroupIndexUpdate(var Message: TMessage);
var
Sender: TComponent;
SenderButton: TSpTBXButtonControl;
begin
if Message.WParam = FGroupIndex then begin
Sender := TComponent(Message.LParam);
if (Sender <> Self) and (Sender is TSpTBXButtonControl) and (Sender.ClassType = Self.ClassType) then begin
SenderButton := Sender as TSpTBXButtonControl;
FAllowAllUp := SenderButton.AllowAllUp;
if SenderButton.Checked and Checked then
Checked := False;
end;
end;
end;
//WMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWM
{ TSpTBXCustomCheckButton }
function TSpTBXCustomCheckButton.GetGlyphSize: TSize;
begin
Result := inherited GetGlyphSize;
if (Result.cx = 0) or (Result.cy = 0) then begin
Result.cx := 13;
Result.cy := 13;
end;
end;
procedure TSpTBXCustomCheckButton.GetSize(out TotalR, TextR, GlyphR: TRect);
begin
inherited GetSize(TotalR, TextR, GlyphR);
// Inc TotalR for the FocusRect
if Autosize then begin
Inc(TotalR.Right);
Inc(TotalR.Bottom, 2);
end;
end;
procedure TSpTBXCustomCheckButton.Toggle;
begin
// Toggle the check state
end;
//WMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWM
{ TSpTBXCustomCheckBox }
constructor TSpTBXCustomCheckBox.Create(AOwner: TComponent);
begin
inherited;
FAllowGrayed := False;
FState := cbUnchecked;
SpaceAsClick := True;
end;
procedure TSpTBXCustomCheckBox.DoInternalGlyphDraw(ACanvas: TCanvas;
AGlyphRect: TRect);
begin
if IsImageIndexValid then
inherited
else
SpDrawXPCheckBoxGlyph(ACanvas, AGlyphRect, Enabled, State, MouseInControl, Pushed, SkinType);
end;
procedure TSpTBXCustomCheckBox.AdjustFont(AFont: TFont);
var
State: TSpTBXSkinStatesType;
begin
if (LinkText <> '') and MouseInControl then
inherited
else
if (SkinType = sknSkin) and ((AFont.Color = clWindowText) or (AFont.Color = clNone)) then begin
State := CurrentSkin.GetState(Enabled, Pushed, MouseInControl, Checked);
AFont.Color := CurrentSkin.GetTextColor(skncCheckBox, State);
end;
end;
procedure TSpTBXCustomCheckBox.Click;
begin
if StateChanged then
inherited
else
Toggle; // Toggle calls OnClick
end;
function TSpTBXCustomCheckBox.GetChecked: Boolean;
begin
Result := FState = cbChecked;
end;
procedure TSpTBXCustomCheckBox.SetChecked(Value: Boolean);
begin
if Checked <> Value then begin
inherited;
if Value then SetState(cbChecked)
else SetState(cbUnchecked);
end;
end;
procedure TSpTBXCustomCheckBox.SetState(const Value: TCheckBoxState);
begin
if (FState <> Value) then begin
FState := Value;
// When State is changed OnClick must be fired
StateChanged := True;
try
Click;
finally
StateChanged := False;
end;
end;
end;
procedure TSpTBXCustomCheckBox.Toggle;
begin
case State of
cbUnchecked: if AllowGrayed then SetState(cbGrayed) else SetState(cbChecked);
cbChecked: SetState(cbUnchecked);
cbGrayed: SetState(cbChecked);
end;
end;
//WMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWM
{ TSpTBXCustomRadioButton }
constructor TSpTBXCustomRadioButton.Create(AOwner: TComponent);
begin
inherited;
TabStop := False;
end;
procedure TSpTBXCustomRadioButton.DoInternalGlyphDraw(ACanvas: TCanvas;
AGlyphRect: TRect);
begin
if IsImageIndexValid then
inherited
else
SpDrawXPRadioButtonGlyph(ACanvas, AGlyphRect, Enabled, Checked, MouseInControl, Pushed, SkinType);
end;
procedure TSpTBXCustomRadioButton.AdjustFont(AFont: TFont);
var
State: TSpTBXSkinStatesType;
begin
if (LinkText <> '') and MouseInControl then
inherited
else
if (SkinType = sknSkin) and ((AFont.Color = clWindowText) or (AFont.Color = clNone)) then begin
State := CurrentSkin.GetState(Enabled, Pushed, MouseInControl, Checked);
AFont.Color := CurrentSkin.GetTextColor(skncRadioButton, State);
end;
end;
function TSpTBXCustomRadioButton.CanUpdateExclusive: Boolean;
begin
// Special case on RadioButtons, UpdateExclusive on all
// the radiobuttons regardless of the GroupIndex
Result := True;
end;
procedure TSpTBXCustomRadioButton.Click;
begin
if StateChanged then
inherited
else
if not Checked then Toggle; // Toggle calls OnClick
end;
procedure TSpTBXCustomRadioButton.CMFocusChanged(var Message: TCMFocusChanged);
begin
inherited;
if Focused then
Toggle;
end;
procedure TSpTBXCustomRadioButton.SetChecked(Value: Boolean);
var
WasChecked: Boolean;
begin
WasChecked := Checked;
inherited;
TabStop := Value;
// When Checked is true OnClick must be fired
if not WasChecked and Value then begin
StateChanged := True;
try
Click;
finally
StateChanged := False;
end;
end;
end;
procedure TSpTBXCustomRadioButton.Toggle;
begin
if not Checked then Checked := True;
end;
//WMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWM
{ TSpTBXRadioGroupButton }
type
TSpTBXRadioGroupButton = class(TSpTBXRadioButton)
public
constructor InternalCreate(RadioGroup: TSpTBXCustomRadioGroup);
destructor Destroy; override;
end;
constructor TSpTBXRadioGroupButton.InternalCreate(RadioGroup: TSpTBXCustomRadioGroup);
begin
inherited Create(RadioGroup);
RadioGroup.FButtons.Add(Self);
Parent := RadioGroup;
AutoSize := False;
Visible := False;
Enabled := RadioGroup.Enabled;
ParentShowHint := False;
TabStop := False;
OnClick := RadioGroup.ButtonClick;
end;
destructor TSpTBXRadioGroupButton.Destroy;
begin
TSpTBXCustomRadioGroup(Owner).FButtons.Remove(Self);
inherited Destroy;
end;
//WMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWM
{ TSpTBXCustomRadioGroup }
constructor TSpTBXCustomRadioGroup.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
ControlStyle := ControlStyle - [csAcceptsControls];
FButtons := TList.Create;
FItems := TTntStringList.Create;
TTntStringList(FItems).OnChange := ItemsChange;
FItemIndex := -1;
FColumns := 1;
end;
destructor TSpTBXCustomRadioGroup.Destroy;
begin
SetButtonCount(0);
TTntStringList(FItems).OnChange := nil;
FItems.Free;
FButtons.Free;
inherited Destroy;
end;
procedure TSpTBXCustomRadioGroup.FlipChildren(AllLevels: Boolean);
begin
{ The radio buttons are flipped using BiDiMode }
end;
procedure TSpTBXCustomRadioGroup.ArrangeButtons;
var
ButtonsPerCol, ButtonWidth, ButtonHeight, TopMargin, I: Integer;
DC: HDC;
SaveFont: HFont;
Metrics: TTextMetric;
DeferHandle: THandle;
ALeft: Integer;
begin
if (FButtons.Count <> 0) and not FReading then
begin
DC := GetDC(0);
SaveFont := SelectObject(DC, Font.Handle);
GetTextMetrics(DC, Metrics);
SelectObject(DC, SaveFont);
ReleaseDC(0, DC);
ButtonsPerCol := (FButtons.Count + FColumns - 1) div FColumns;
ButtonWidth := (Width - 10) div FColumns;
I := Height - Metrics.tmHeight - 5;
ButtonHeight := I div ButtonsPerCol;
TopMargin := Metrics.tmHeight + 1 + (I mod ButtonsPerCol) div 2;
DeferHandle := BeginDeferWindowPos(FButtons.Count);
try
for I := 0 to FButtons.Count - 1 do
with TSpTBXRadioGroupButton(FButtons[I]) do
begin
BiDiMode := Self.BiDiMode;
ALeft := (I div ButtonsPerCol) * ButtonWidth + 8;
if UseRightToLeftAlignment then
ALeft := Self.ClientWidth - ALeft - ButtonWidth;
DeferHandle := DeferWindowPos(DeferHandle, Handle, 0,
ALeft,
(I mod ButtonsPerCol) * ButtonHeight + TopMargin,
ButtonWidth, ButtonHeight,
SWP_NOZORDER or SWP_NOACTIVATE);
Visible := True;
end;
finally
EndDeferWindowPos(DeferHandle);
end;
end;
end;
procedure TSpTBXCustomRadioGroup.ButtonClick(Sender: TObject);
begin
if not FUpdating then begin
FItemIndex := FButtons.IndexOf(Sender);
Changed;
Click;
end;
end;
procedure TSpTBXCustomRadioGroup.InvalidateBackground(InvalidateChildren: Boolean);
var
I: Integer;
T: TSpTBXSkinType;
begin
inherited;
if not InvalidateChildren and not (csDestroying in ComponentState) then
if HandleAllocated then begin
T := SkinType;
for I := 0 to FButtons.Count - 1 do
Buttons[I].SkinType := T;
end;
end;
procedure TSpTBXCustomRadioGroup.ItemsChange(Sender: TObject);
begin
if not FReading then begin
if FItemIndex >= FItems.Count then FItemIndex := FItems.Count - 1;
UpdateButtons;
end;
end;
procedure TSpTBXCustomRadioGroup.Loaded;
begin
inherited Loaded;
ArrangeButtons;
end;
procedure TSpTBXCustomRadioGroup.ReadState(Reader: TReader);
begin
FReading := True;
try
inherited ReadState(Reader);
finally
FReading := False;
end;
UpdateButtons;
end;
procedure TSpTBXCustomRadioGroup.SetButtonCount(Value: Integer);
begin
while FButtons.Count < Value do
TSpTBXRadioGroupButton.InternalCreate(Self);
while FButtons.Count > Value do
TSpTBXRadioGroupButton(FButtons.Last).Free;
end;
procedure TSpTBXCustomRadioGroup.SetColumns(Value: Integer);
begin
if Value < 1 then Value := 1;
if Value > 16 then Value := 16;
if FColumns <> Value then begin
FColumns := Value;
ArrangeButtons;
Invalidate;
end;
end;
procedure TSpTBXCustomRadioGroup.SetFocus;
begin
inherited;
if Enabled and (FItemIndex > -1) then
GetButtons(FItemIndex).SetFocus;
end;
procedure TSpTBXCustomRadioGroup.SetItemIndex(Value: Integer);
begin
if FReading then
FItemIndex := Value
else begin
if Value < -1 then Value := -1;
if Value >= FButtons.Count then Value := FButtons.Count - 1;
if FItemIndex <> Value then
begin
if FItemIndex >= 0 then
GetButtons(FItemIndex).Checked := False;
FItemIndex := Value;
if FItemIndex >= 0 then
GetButtons(FItemIndex).Checked := True;
end;
end;
end;
procedure TSpTBXCustomRadioGroup.SetItems(Value: TTntStrings);
begin
FItems.Assign(Value);
end;
procedure TSpTBXCustomRadioGroup.UpdateButtons;
var
I: Integer;
begin
SetButtonCount(FItems.Count);
for I := 0 to FButtons.Count - 1 do
Buttons[I].Caption := FItems[I];
if FItemIndex >= 0 then begin
FUpdating := True;
try
GetButtons(FItemIndex).Checked := True;
finally
FUpdating := False;
end;
end;
ArrangeButtons;
Invalidate;
end;
procedure TSpTBXCustomRadioGroup.CMEnabledChanged(var Message: TMessage);
var
I: Integer;
begin
inherited;
for I := 0 to FButtons.Count - 1 do
GetButtons(I).Enabled := Enabled;
end;
procedure TSpTBXCustomRadioGroup.CMFontChanged(var Message: TMessage);
begin
inherited;
ArrangeButtons;
end;
procedure TSpTBXCustomRadioGroup.WMSize(var Message: TWMSize);
begin
inherited;
ArrangeButtons;
end;
procedure TSpTBXCustomRadioGroup.GetChildren(Proc: TGetChildProc; Root: TComponent);
begin
// Do nothing
end;
function TSpTBXCustomRadioGroup.GetButtons(Index: Integer): TSpTBXRadioButton;
begin
Result := TSpTBXRadioButton(FButtons[Index]);
end;
//WMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWM
{ TSpTBXCustomButton }
constructor TSpTBXCustomButton.Create(AOwner: TComponent);
begin
inherited;
FBitmapTransparent := True;
FBitmap := TBitmap.Create;
FBitmap.OnChange := BitmapChanged;
FPopupControl := Self;
FDropDownArrow := True;
Alignment := taCenter;
Autosize := False;
DrawPushedCaption := True;
SpaceAsClick := True;
Width := 75;
Height := 25;
end;
destructor TSpTBXCustomButton.Destroy;
begin
StopRepeat;
FBitmap.Free;
inherited;
end;
procedure TSpTBXCustomButton.CreateWnd;
begin
inherited;
FActive := FDefault;
end;
procedure TSpTBXCustomButton.AdjustFont(AFont: TFont);
var
State: TSpTBXSkinStatesType;
begin
if (LinkText <> '') and MouseInControl then
inherited
else
if (SkinType = sknSkin) and ((AFont.Color = clWindowText) or (AFont.Color = clNone)) then begin
State := CurrentSkin.GetState(Enabled, Pushed, MouseInControl, Checked);
AFont.Color := CurrentSkin.GetTextColor(skncButton, State);
end;
end;
procedure TSpTBXCustomButton.BitmapChanged(Sender: TObject);
begin
Invalidate;
end;
function TSpTBXCustomButton.BitmapValid: boolean;
begin
Result := (Bitmap <> nil) and (not Bitmap.Empty) and (Bitmap.Height mod ConstStatesCount = 0);
end;
procedure TSpTBXCustomButton.Click;
var
P: TPoint;
Form: TCustomForm;
M: TPopupMenu;
SpTBXPopup: ISpTBXPopupMenu;
procedure RemoveClicks;
var
RepostList: TList;
Repost: Boolean;
I: Integer;
Msg: TMsg;
P: TPoint;
begin
RepostList := TList.Create;
try
while PeekMessage(Msg, 0, WM_LBUTTONDOWN, WM_MBUTTONDBLCLK, PM_REMOVE) do
with Msg do
begin
Repost := True;
case Message of
WM_QUIT: begin
{ Throw back any WM_QUIT messages }
PostQuitMessage(wParam);
Break;
end;
WM_LBUTTONDOWN, WM_LBUTTONDBLCLK,
WM_RBUTTONDOWN, WM_RBUTTONDBLCLK,
WM_MBUTTONDOWN, WM_MBUTTONDBLCLK: begin
P := SmallPointToPoint(TSmallPoint(lParam));
Windows.ClientToScreen(hwnd, P);
if FindDragTarget(P, True) = Self then Repost := False;
end;
end;
if Repost then
begin
RepostList.Add(AllocMem(SizeOf(TMsg)));
PMsg(RepostList.Last)^ := Msg;
end;
end;
for I := 0 to RepostList.Count-1 do
begin
with PMsg(RepostList[I])^ do PostMessage(hwnd, message, wParam, lParam);
FreeMem(RepostList[I]);
end;
finally
RepostList.Free;
end;
end;
begin
if not FRepeating then begin
M := GetInternalDropDownMenu;
if Assigned(M) then begin
FDropDownMenuVisible := True;
try
UpdateTracking(True);
MouseCapture := False;
M.PopupComponent := Self;
if M.GetInterface(ISpTBXPopupMenu, SpTBXPopup) then begin
if not SpTBXPopup.InternalPopup(0, 0, False, FPopupControl) then
FDropDownMenuVisible := False;
end
else begin
P := ClientToScreen(Point(0, Height));
M.Popup(P.X, P.Y);
FDropDownMenuVisible := False;
end;
finally
Invalidate;
RemoveClicks;
end;
Exit; // don't call the Click handler if the DropDownMenu is shown
end;
Form := GetParentForm(Self);
if Assigned(Form) then Form.ModalResult := FModalResult;
end;
inherited;
end;
function TSpTBXCustomButton.DoDrawDropDownArrow(ACanvas: TCanvas;
ARect: TRect): Boolean;
var
R: TRect;
P: TPoint;
begin
Result := True;
if FDropDownArrow and Assigned(FDropDownMenu) then begin
R := ARect;
R.Left := R.Right - GetTextMargins.Right;
P.X := (R.Left + R.Right) div 2 - 1;
P.Y := (R.Top + R.Bottom) div 2 - 1;
SpDrawArrow(ACanvas, P.X, P.Y, ACanvas.Font.Color, True, False, 2);
end;
end;
function TSpTBXCustomButton.DoDrawItem(ACanvas: TCanvas; ARect: TRect;
const PaintStage: TSpTBXPaintStage): Boolean;
var
B: TBitmap;
T: TSpTBXSkinType;
State: TSpTBXSkinStatesType;
Defaulted: Boolean;
begin
Result := inherited DoDrawItem(ACanvas, ARect, PaintStage);
if Result and (PaintStage = pstPrePaint) then
// When Flat is true draw the button only when it's needed
if not Flat or (MouseInControl or Focused or FPushed or Checked) then begin
if BitmapValid then begin
B := TBitmap.Create;
try
B.Width := ARect.Right - ARect.Left;
B.Height := ARect.Bottom - ARect.Top;
SetStretchBltMode(B.Canvas.Handle, COLORONCOLOR);
B.Canvas.CopyRect(ARect, Bitmap.Canvas, GetSkinStateRect);
if FBitmapTransparent then
B.Transparent := True;
ACanvas.Draw(0, 0, B);
finally
B.Free;
end;
end
else begin
T := SpTBXSkinType(SkinType);
if Flat and FToolbarStyle then begin
State := CurrentSkin.GetState(Enabled, Pushed, MouseInControl, Checked);
SpDrawXPToolbarButton(ACanvas, ARect, State, T);
end
else begin
if T = sknSkin then
Defaulted := False
else
Defaulted := FActive;
SpDrawXPButton(ACanvas, ARect, Enabled, Pushed, MouseInControl, Checked, False, Defaulted, T);
end;
end;
end;
// Draw the button arrow
if Result and (PaintStage = pstPostPaint) then
DoDrawDropDownArrow(ACanvas, ARect);
end;
function TSpTBXCustomButton.GetFocused: Boolean;
begin
Result := Focused and (IsDroppedDown or (inherited GetFocused));
end;
function TSpTBXCustomButton.GetFocusRect(R, TextR, GlyphR: TRect): TRect;
begin
Result := R;
if SpTBXSkinType(SkinType) = sknNone then
InflateRect(Result, -4, -4)
else
InflateRect(Result, -3, -3);
end;
function TSpTBXCustomButton.GetInternalDropDownMenu: TPopupMenu;
begin
Result := FDropDownMenu;
end;
function TSpTBXCustomButton.GetPushed: Boolean;
begin
Result := IsDroppedDown or (inherited GetPushed);
end;
function TSpTBXCustomButton.GetTextMargins: TRect;
const
ArrowWidth = 5;
begin
Result := Rect(8, 2, 8, 2);
if FDropDownArrow and Assigned(FDropdownMenu) then
Inc(Result.Right, ArrowWidth + 4);
end;
function TSpTBXCustomButton.IsDroppedDown: Boolean;
begin
Result := FDropDownMenuVisible;
end;
function TSpTBXCustomButton.GetSkinStateRect: TRect;
var
W, H: integer;
begin
// Finds the skin rect based on the button state
Result := Rect(0, 0, 0, 0);
if BitmapValid then begin
W := Bitmap.Width;
H := (Bitmap.Height div ConstStatesCount); // 4 states
if not Enabled then
Result := Bounds(0, H * 3, W, H) // 4th state (disabled)
else begin
if Checked or Pushed then
Result := Bounds(0, H * 2, W, H) // 3rd state (down)
else
if MouseInControl then
Result := Bounds(0, H * 1, W, H) // 2nd state (hottrack)
else
Result := Bounds(0, H * 0, W, H); // 1st state (up)
end;
end;
end;
procedure TSpTBXCustomButton.MouseDown(Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
inherited;
if Enabled and (Button = mbLeft) then begin
if Repeating then begin
Click;
ControlState := ControlState - [csClicked];
if not Assigned(FRepeatTimer) then FRepeatTimer := TTimer.Create(Self);
FRepeatTimer.Interval := ConstInitRepeatPause;
FRepeatTimer.OnTimer := RepeatTimerHandler;
FRepeatTimer.Enabled := True;
end;
end;
end;
procedure TSpTBXCustomButton.MouseUp(Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
inherited;
if Button = mbLeft then StopRepeat;
end;
procedure TSpTBXCustomButton.Notification(AComponent: TComponent;
Operation: TOperation);
begin
inherited;
if Operation = opRemove then
if AComponent = DropdownMenu then DropdownMenu := nil;
end;
procedure TSpTBXCustomButton.RepeatTimerHandler(Sender: TObject);
begin
FRepeatTimer.Interval := ConstRepeatPause;
if Repeating then begin
if Pushed then
Click;
end
else
StopRepeat;
end;
procedure TSpTBXCustomButton.StopRepeat;
begin
if Assigned(FRepeatTimer) then begin
FRepeatTimer.Free;
FRepeatTimer := nil;
end;
end;
procedure TSpTBXCustomButton.SetBitmap(const Value: TBitmap);
begin
FBitmap.Assign(Value);
Invalidate;
end;
procedure TSpTBXCustomButton.SetDefault(const Value: Boolean);
var
Form: TCustomForm;
begin
FDefault := Value;
if HandleAllocated then begin
Form := GetParentForm(Self);
if Assigned(Form) then
Form.Perform(CM_FOCUSCHANGED, 0, Longint(Form.ActiveControl));
end;
end;
procedure TSpTBXCustomButton.SetDropDownArrow(const Value: Boolean);
begin
if FDropDownArrow <> Value then begin
FDropDownArrow := Value;
Invalidate;
end;
end;
procedure TSpTBXCustomButton.SetDropDownMenu(Value: TPopupMenu);
begin
if FDropDownMenu <> Value then begin
if Assigned(FDropDownMenu) then RemoveFreeNotification(FDropDownMenu);
FDropDownMenu := Value;
if Assigned(FDropDownMenu) then FreeNotification(FDropDownMenu);
Invalidate;
end;
end;
procedure TSpTBXCustomButton.SetFlat(const Value: Boolean);
begin
if FFlat <> Value then begin
FFlat := Value;
Invalidate;
end;
end;
procedure TSpTBXCustomButton.CMDialogKey(var Message: TCMDialogKey);
begin
with Message do
if (((CharCode = VK_RETURN) and FActive) or
((CharCode = VK_ESCAPE) and FCancel)) and
(KeyDataToShiftState(Message.KeyData) = []) and CanFocus then
begin
Click;
Result := 1;
end
else
inherited;
end;
procedure TSpTBXCustomButton.CMFocusChanged(var Message: TCMFocusChanged);
begin
with Message do
if Sender is TSpTBXCustomButton then
FActive := Sender = Self
else
FActive := FDefault;
inherited;
end;
procedure TSpTBXCustomButton.CMSPPopupClose(var Message: TMessage);
begin
FDropDownMenuVisible := False;
Invalidate;
inherited;
end;
procedure TSpTBXCustomButton.WMCancelMode(var Message: TWMCancelMode);
begin
inherited;
StopRepeat;
UpdateTracking(True);
end;
//WMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWM
{ TSpTBXCustomSpeedButton }
constructor TSpTBXCustomSpeedButton.Create(AOwner: TComponent);
begin
inherited;
ControlStyle := ControlStyle - [csSetCaption];
SetBounds(0, 0, 23, 22);
ToolbarStyle := True;
end;
function TSpTBXCustomSpeedButton.CanFocus: Boolean;
begin
Result := False;
end;
procedure TSpTBXCustomSpeedButton.Click;
begin
if FGroupIndex <> 0 then
if AllowAllUp then
Checked := not Checked
else
Checked := True;
inherited
end;
//WMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWM
{ TSpTBXCustomProgressBar }
constructor TSpTBXCustomProgressBar.Create(AOwner: TComponent);
begin
inherited;
FMax := 100;
FMin := 0;
FPosition := 0;
FProgressVisible := True;
FCaptionGlow := gldAll;
FCaptionType := pctPercentage;
Alignment := taCenter;
Autosize := False;
Width := 150;
Height := 17;
Font.Style := Font.Style + [fsBold];
TabStop := False;
end;
procedure TSpTBXCustomProgressBar.AdjustFont(AFont: TFont);
var
State: TSpTBXSkinStatesType;
begin
if (LinkText <> '') and MouseInControl then
inherited
else
if (SkinType = sknSkin) and ((AFont.Color = clWindowText) or (AFont.Color = clNone)) then begin
State := CurrentSkin.GetState(Enabled, Pushed, MouseInControl, Checked);
AFont.Color := CurrentSkin.GetTextColor(skncProgressBar, State);
end;
end;
function TSpTBXCustomProgressBar.DoDrawItem(ACanvas: TCanvas; ARect: TRect;
const PaintStage: TSpTBXPaintStage): Boolean;
var
I: Integer;
T: TSpTBXSkinType;
begin
Result := inherited DoDrawItem(ACanvas, ARect, PaintStage);
if Result and (PaintStage = pstPrePaint) then begin
T := SpTBXSkinType(SkinType);
I := SpDrawXPProgressBar(ACanvas, ARect, FVertical, FSmooth, FProgressVisible, FMin, FMax, FPosition, T);
case FCaptionType of
pctNone: Caption := '';
pctPercentage: Caption := IntToStr(I) + '%';
pctProgress: Caption := IntToStr(FPosition);
end;
end;
end;
procedure TSpTBXCustomProgressBar.DoProgressChange;
begin
if Assigned(FOnProgressChange) then FOnProgressChange(Self, Position);
end;
function TSpTBXCustomProgressBar.GetTextMargins: TRect;
begin
Result := Rect(8, 2, 8, 2);
end;
procedure TSpTBXCustomProgressBar.SetCaptionType(const Value: TSpTBXProgressCaption);
begin
if FCaptionType <> Value then begin
FCaptionType := Value;
if Value <> pctDefault then Caption := '';
Invalidate;
end;
end;
procedure TSpTBXCustomProgressBar.SetMax(const Value: integer);
begin
if FMax <> Value then begin
FMax := Value;
Invalidate;
end;
end;
procedure TSpTBXCustomProgressBar.SetMin(const Value: integer);
begin
if FMin <> Value then begin
FMin := Value;
Invalidate;
end;
end;
procedure TSpTBXCustomProgressBar.SetPosition(Value: integer);
begin
if Value > FMax then Value := FMax
else if Value < FMin then Value := FMin;
if FPosition <> Value then begin
FPosition := Value;
Invalidate;
DoProgressChange;
end;
end;
procedure TSpTBXCustomProgressBar.SetProgressVisible(const Value: Boolean);
begin
if FProgressVisible <> Value then begin
FProgressVisible := Value;
Invalidate;
end;
end;
procedure TSpTBXCustomProgressBar.SetSmooth(const Value: Boolean);
begin
if FSmooth <> Value then begin
FSmooth := Value;
Invalidate;
end;
end;
procedure TSpTBXCustomProgressBar.SetVertical(const Value: Boolean);
begin
if FVertical <> Value then begin
FVertical := Value;
if FVertical then
FCaptionRoatationAngle := tra90
else
FCaptionRoatationAngle := tra0;
if Width > Height then
SetBounds(Left, Top, Height, Width);
Invalidate;
end;
end;
procedure TSpTBXCustomProgressBar.StepIt(Delta: Integer = 1);
begin
SetPosition(FPosition + Delta);
end;
//WMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWM
{ TSpTBXTrackBar }
constructor TSpTBXTrackBar.Create(AOwner: TComponent);
begin
inherited;
FSkinType := sknSkin;
FTickMarks := tmxBottomRight;
SkinManager.AddSkinNotification(Self);
end;
procedure TSpTBXTrackBar.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params);
FCanDrawChannelSelection := (Params.Style and TBS_ENABLESELRANGE) <> 0;
end;
destructor TSpTBXTrackBar.Destroy;
begin
SkinManager.RemoveSkinNotification(Self);
inherited;
end;
function TSpTBXTrackBar.ChannelRect: TRect;
var
R: TRect;
begin
// TBM_GETCHANNELRECT allways returns the horizontal channel rect, even
// when the Orientation is vertical.
SendMessage(Handle, TBM_GETCHANNELRECT, 0, Integer(@Result));
if Orientation = trVertical then begin
R := Result;
Result := Rect(R.Top, R.Left, R.Bottom, R.Right);
end;
end;
function TSpTBXTrackBar.DoDrawChannel(ACanvas: TCanvas; ARect: TRect;
const PaintStage: TSpTBXPaintStage): Boolean;
begin
Result := True;
if Assigned(FOnDrawChannel) then FOnDrawChannel(Self, ACanvas, ARect, PaintStage, Result);
end;
function TSpTBXTrackBar.DoDrawChannelTicks(ACanvas: TCanvas; X, Y: Integer): Boolean;
begin
Result := True;
if Assigned(FOnDrawChannelTicks) then FOnDrawChannelTicks(Self, ACanvas, X, Y, Result);
end;
function TSpTBXTrackBar.DoDrawThumb(ACanvas: TCanvas; ARect: TRect;
const PaintStage: TSpTBXPaintStage): Boolean;
begin
Result := True;
if Assigned(FOnDrawThumb) then FOnDrawThumb(Self, ACanvas, ARect, PaintStage, Result);
end;
procedure TSpTBXTrackBar.DrawTicks(ACanvas: TCanvas);
var
PosArray: array of Integer;
I, Count, Y, iStart, iEnd: Integer;
ChannelR, ThumbR: TRect;
FirstTickSize, TickSize, TickDelta: Integer;
LastPenColor: TColor;
begin
if TickStyle = tsNone then Exit;
// Returns the position of the ticks on the client area
// Check if Max - Min > 2 to see if the ticks array is valid.
Count := Max - Min;
if Count < 2 then
Count := 2
else
Count := Count + 1;
SetLength(PosArray, Count);
// Fill the array, the first and last ticks are not included in the ticks array:
// http://msdn.microsoft.com/library/en-us/shellcc/platform/commctls/trackbar/messages/tbm_getticpos.asp?frame=true
// First we need to get the middle ticks
// 0 1 2 3 4 5 6 7 8 9 // Tick positions seen on the trackbar.
// 1 2 3 4 5 6 7 8 // Tick positions whose position can be identified.
// 0 1 2 3 4 5 6 7 // Index numbers for the identifiable positions.
if Count >= 2 then begin
iStart := 1;
iEnd := Count - 1 - 1;
for I := iStart to iEnd do
PosArray[I] := SendMessage(Self.Handle, TBM_GETTICPOS, I - 1, 0);
end;
LastPenColor := ACanvas.Pen.Color;
case SpTBXSkinType(FSkinType) of
sknNone:
ACanvas.Pen.Color := clBlack;
sknWindows:
ACanvas.Pen.Color := clBtnShadow;
sknSkin:
if CurrentSkin.Options(skncTrackBar, sknsNormal).TextColor <> clNone then
ACanvas.Pen.Color := CurrentSkin.Options(skncTrackBar, sknsNormal).TextColor
else
ACanvas.Pen.Color := clBtnShadow;
end;
SendMessage(Self.Handle, TBM_GETTHUMBRECT, 0, Integer(@ThumbR));
ChannelR := ChannelRect;
FirstTickSize := 4;
TickSize := 3;
Y := 0;
if Orientation = trHorizontal then begin
I := (ThumbR.Right - ThumbR.Left) div 2;
PosArray[0] := ChannelR.Left + I;
PosArray[Count - 1] := ChannelR.Right - I - 1;
case TickMarks of
tmxBottomRight:
begin
Y := ThumbR.Bottom + 1;
FirstTickSize := 4;
TickSize := 3;
end;
tmxTopLeft:
begin
Y := ThumbR.Top - 2;
FirstTickSize := -4;
TickSize := -3;
end;
tmxBoth:
begin
Y := ThumbR.Top - 2;
FirstTickSize := -4;
TickSize := -3;
end;
tmxCenter:
begin
Y := ChannelR.Top + (ChannelR.Bottom - ChannelR.Top) div 2;
FirstTickSize := 1;
TickSize := 1;
end;
end;
for I := 0 to Count - 1 do
if DoDrawChannelTicks(ACanvas, PosArray[I], Y) then begin
TickDelta := 0;
if (I = 0) or (I = Count - 1) then
TickDelta := FirstTickSize
else
if TickStyle = tsManual then TickDelta := TickSize
else if I mod Frequency = 0 then TickDelta := TickSize;
if TickDelta <> 0 then begin
ACanvas.MoveTo(PosArray[I], Y);
ACanvas.LineTo(PosArray[I], Y + TickDelta);
if TickMarks = tmxBoth then begin
ACanvas.MoveTo(PosArray[I], ThumbR.Bottom + 1);
ACanvas.LineTo(PosArray[I], ThumbR.Bottom + 1 - TickDelta);
end;
end;
end;
end
else begin
I := (ThumbR.Bottom - ThumbR.Top) div 2;
PosArray[0] := ChannelR.Top + I;
PosArray[Count - 1] := ChannelR.Bottom - I - 1;
case TickMarks of
tmxBottomRight:
begin
Y := ThumbR.Right + 1;
FirstTickSize := 4;
TickSize := 3;
end;
tmxTopLeft:
begin
Y := ThumbR.Left - 2;
FirstTickSize := -4;
TickSize := -3;
end;
tmxBoth:
begin
Y := ThumbR.Left - 2;
FirstTickSize := -4;
TickSize := -3;
end;
tmxCenter:
begin
Y := ChannelR.Left + (ChannelR.Right - ChannelR.Left) div 2;
FirstTickSize := 1;
TickSize := 1;
end;
end;
for I := 0 to Count - 1 do
if DoDrawChannelTicks(ACanvas, Y, PosArray[I]) then begin
TickDelta := 0;
if (I = 0) or (I = Count - 1) then
TickDelta := FirstTickSize
else
if TickStyle = tsManual then TickDelta := TickSize
else if I mod Frequency = 0 then TickDelta := TickSize;
if TickDelta <> 0 then begin
ACanvas.MoveTo(Y, PosArray[I]);
ACanvas.LineTo(Y + TickDelta, PosArray[I]);
if TickMarks = tmxBoth then begin
ACanvas.MoveTo(ThumbR.Right + 1, PosArray[I]);
ACanvas.LineTo(ThumbR.Right + 1 - TickDelta, PosArray[I]);
end;
end;
end;
end;
ACanvas.Pen.Color := LastPenColor;
end;
function TSpTBXTrackBar.MouseInThumb: Boolean;
var
P: TPoint;
R: TRect;
begin
if csDesigning in ComponentState then
Result := False
else begin
SendMessage(Handle, TBM_GETTHUMBRECT, 0, Integer(@R));
GetCursorPos(P);
P := ScreenToClient(P);
Result := PtInRect(R, P)
end;
if SpTBXSkinType(SkinType) = sknWindows then begin
if Focused then Result := not (GetCaptureControl = Self);
end
else
Result := GetCaptureControl = Self;
end;
procedure TSpTBXTrackBar.InvalidateBackground;
begin
// Invalidate, Repaint, Update, SetWindowPos and RedrawWindow doesn't work
// on Trackbars (CN_NOTIFY messages are not sent), we have to send a
// WM_SIZE message in order to invalidate the control.
if HandleAllocated then
SendMessage(Handle, WM_SIZE, SIZE_RESTORED, MakeLParam(Width, Height));
end;
procedure TSpTBXTrackBar.SetSkinType(const Value: TSpTBXSkinType);
begin
if Value <> FSkinType then begin
FSkinType := Value;
InvalidateBackground;
end;
end;
procedure TSpTBXTrackBar.SetTickMarks(const Value: TSpTBXTickMark);
const
A: array [TSpTBXTickMark] of TTickMark = (tmBottomRight, tmTopLeft, tmBoth, tmBoth);
begin
if Value <> FTickMarks then begin
if A[FTickMarks] = A[Value] then begin
FTickMarks := Value;
inherited TickMarks := A[Value];
RecreateWnd;
end
else begin
FTickMarks := Value;
inherited TickMarks := A[Value];
end;
end;
end;
procedure TSpTBXTrackBar.CMSpTBXControlsInvalidate(var Message: TMessage);
begin
InvalidateBackground;
Message.Result := 1;
end;
procedure TSpTBXTrackBar.CNNotify(var Message: TWMNotify);
var
Info: PNMCustomDraw;
ACanvas: TCanvas;
R: TRect;
Rgn: HRGN;
Offset: Integer;
begin
if Message.NMHdr.code = NM_CUSTOMDRAW then begin
Message.Result := CDRF_DODEFAULT;
Info := Pointer(Message.NMHdr);
case Info.dwDrawStage of
CDDS_PREPAINT:
Message.Result := CDRF_NOTIFYITEMDRAW;
CDDS_ITEMPREPAINT:
begin
ACanvas := TCanvas.Create;
ACanvas.Lock;
try
ACanvas.Handle := Info.hdc;
case Info.dwItemSpec of
TBCD_TICS:
begin
R := ClientRect;
SpDrawParentBackground(Self, ACanvas.Handle, R);
if Focused then
SpDrawFocusRect(ACanvas, R);
if FTickMarks <> tmxCenter then
DrawTicks(ACanvas);
Message.Result := CDRF_SKIPDEFAULT;
end;
TBCD_THUMB:
begin
if SliderVisible then begin
SendMessage(Handle, TBM_GETTHUMBRECT, 0, Integer(@R));
if DoDrawThumb(ACanvas, R, pstPrePaint) then
SpDrawXPTrackBar(ACanvas, R, TBCD_THUMB, Orientation = trVertical, MouseInThumb, False, FTickMarks, Min, Max, SelStart, SelEnd, FSkinType);
DoDrawThumb(ACanvas, R, pstPostPaint);
Message.Result := CDRF_SKIPDEFAULT;
end;
end;
TBCD_CHANNEL:
begin
SendMessage(Handle, TBM_GETTHUMBRECT, 0, Integer(@R));
Offset := 0;
if Focused then
Inc(Offset);
if Orientation = trHorizontal then begin
R.Left := ClientRect.Left + Offset;
R.Right := ClientRect.Right - Offset;
end
else begin
R.Top := ClientRect.Top + Offset;
R.Bottom := ClientRect.Bottom - Offset;
end;
with R do
Rgn := CreateRectRgn(Left, Top, Right, Bottom);
SelectClipRgn(ACanvas.Handle, Rgn);
try
SpDrawParentBackground(Self, ACanvas.Handle, ClientRect);
R := ChannelRect;
if DoDrawChannel(ACanvas, R, pstPrePaint) then
SpDrawXPTrackBar(ACanvas, R, TBCD_CHANNEL, Orientation = trVertical, False, FCanDrawChannelSelection, FTickMarks, Min, Max, SelStart, SelEnd, FSkinType);
DoDrawChannel(ACanvas, R, pstPostPaint);
// Draw channel tics
if FTickMarks = tmxCenter then
DrawTicks(ACanvas);
finally
DeleteObject(Rgn);
SelectClipRgn(ACanvas.Handle, 0);
end;
Message.Result := CDRF_SKIPDEFAULT;
end;
end;
finally
ACanvas.Unlock;
ACanvas.Handle := 0;
ACanvas.Free;
end;
end;
end;
end;
end;
procedure TSpTBXTrackBar.WMEraseBkGnd(var Message: TMessage);
begin
if SpTBXSkinType(SkinType) <> sknNone then
Message.Result := 1
else
inherited;
end;
procedure TSpTBXTrackBar.WMSpSkinChange(var Message: TMessage);
begin
InvalidateBackground;
end;
end.
Reference in New Issue View Git Blame Copy Permalink