Answer:
I needed to make a Button that has a two state property on/off like the ones used to start the MS SQL Server yet still have most of the TSpeedbution functionality. After playing with TSpeedbutton and not quite getting it to behave the way that I wanted. I decided to see how Borland implemented TSpeedbutton, the source is in Buttons.pas. TSpeedbutton I discovered uses a set of sub classes TGlyphList, TGlyphCache, and TButtonGlyph. These sub classes are the core of TSpeedbutton I realized that in order to get the behavior that I wanted I would have to create my own implimentation based on this code. I decided to also add a default glyph containing the base on/off arrows. Also I dropped the AllowUp property as that it does not pertain to an on or off button since the state is on or off. The Code is quite long. I have supplied a zip file containing all the code.
unit OnOffBtn;
{
Author: Peter S. Coe Jr.
Company: PCOE Computer Services, Inc.
Date: Febuary 23, 2003
You may alter and distribute this code as you wish we only ask that you leave
the reference to the original Author, Company, and Date.
This Code is based on the code in Button.pas for the TSpeedButton component
execept the states.
The Button is ON/Down or OFF/Up
Enabled Posistions user intereaction allowed
bsUP = bsOFF - Button is OFF/Up
bsDisabled = bsON - Button is ON/Down
Disabled Positions user interaction disallowed
bsDown = bsDisabledOFF - Button is in the Off/Up Position but disabled
bsExclusive = bsDisabledON - Button is in the On/Down Position but disabled
}
interface
uses
Windows, Messages, Classes, Controls, Forms, Graphics, StdCtrls,
ExtCtrls, CommCtrl,ActnList,ImgList;
type
{ Redefine the types used by the button so they are not confused with TSpeedButttons }
TOnOffBtnLayout = (blGlyphLeft, blGlyphRight, blGlyphTop, blGlyphBottom);
TOnOffBtnState = (bsOFF, bsON, bsDisabledOFF, bsDisabledON);
TOnOffBtnStyle = (bsAutoDetect, bsWin31, bsNew);
TOnOffBtnNumGlyphs = 1..4;
TOnOffBtn = class;
{Action Control Link}
TOnOffBtnActionLink = class(TControlActionLink)
protected
FClient: TOnOffBtn;
procedure AssignClient(AClient: TObject); override;
function IsCheckedLinked: Boolean; override;
function IsGroupIndexLinked: Boolean; override;
procedure SetGroupIndex(Value: Integer); override;
procedure SetChecked(Value: Boolean); override;
end;
TOnOffBtn = class(TGraphicControl)
private
FOnOff : Boolean; // On replaced FDown
FDragging : Boolean;
FFlat : Boolean;
FGlyph : Pointer;
FGroupIndex : Integer;
FLayout : TOnOffBtnLayout;
FMargin : Integer;
FMouseInControl : Boolean;
FSpacing : Integer;
FTransparent : Boolean;
procedure CMButtonPressed(var Message: TMessage); message CM_BUTTONPRESSED;
procedure CMDialogChar(var Message: TCMDialogChar); message CM_DIALOGCHAR;
procedure CMEnabledChanged(var Message: TMessage); message CM_ENABLEDCHANGED;
procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
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 CMSysColorChange(var Message: TMessage); message CM_SYSCOLORCHANGE;
function GetGlyph: TBitmap;
procedure GlyphChanged(Sender: TObject);
function GetNumGlyphs: TOnOffBtnNumGlyphs;
procedure SetOnOff(Value: Boolean);
procedure SetFlat(Value: Boolean);
procedure SetGlyph(Value: TBitmap);
procedure SetGroupIndex(Value: Integer);
procedure SetLayout(Value: TOnOffBtnLayout);
procedure SetMargin(Value: Integer);
procedure SetNumGlyphs(Value: TOnOffBtnNumGlyphs);
procedure SetSpacing(Value: Integer);
procedure SetTransparent(Value: Boolean);
procedure UpdateExclusive;
procedure UpdateTracking;
procedure WMLButtonDblClk(var Message: TWMLButtonDown); message WM_LBUTTONDBLCLK;
protected
FState : TOnOffBtnState;
procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override;
function GetActionLinkClass: TControlActionLinkClass; override;
function GetPalette: HPALETTE; override;
procedure Loaded; override;
procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
procedure Paint; override;
property MouseInControl: Boolean read FMouseInControl;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure Click; override;
published
property Action;
property Anchors;
property BiDiMode;
property Constraints;
property GroupIndex: Integer read FGroupIndex write SetGroupIndex default 0;
property OnOff: Boolean read FOnOff write SetOnOff default False; // the Off Position
property Caption;
property Enabled;
property Flat: Boolean read FFlat write SetFlat default False;
property Font;
property Glyph: TBitmap read GetGlyph write SetGlyph;
property Layout: TOnOffBtnLayout read FLayout write SetLayout default blGlyphLeft;
property Margin: Integer read FMargin write SetMargin default -1;
property NumGlyphs: TOnOffBtnNumGlyphs read GetNumGlyphs write SetNumGlyphs default 1;
property ParentFont;
property ParentShowHint;
property ParentBiDiMode;
property PopupMenu;
property ShowHint;
property Spacing: Integer read FSpacing write SetSpacing default 4;
property Transparent: Boolean read FTransparent write SetTransparent default True;
property Visible;
property OnClick;
property OnDblClick;
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
end;
function DrawBtnFace(Canvas: TCanvas; const Client: TRect;
BevelWidth: Integer; Style: TOnOffBtnStyle; IsRounded, IsDown,
IsFocused: Boolean): TRect;
procedure Register;
implementation
{$R *.res} //Contains the Component Icon bitmap and the Default Glyph bitmap
{I could not find a reference to what this function is used for if anyone can tell me I would like to know original name was DrawButtonFace}
function DrawBtnFace(Canvas: TCanvas; const Client: TRect;
BevelWidth: Integer; Style: TOnOffBtnStyle; IsRounded, IsDown,
IsFocused: Boolean): TRect;
var
NewStyle: Boolean;
R: TRect;
DC: THandle;
begin
NewStyle := ((Style = bsAutoDetect) and NewStyleControls) or (Style = bsNew);
R := Client;
with Canvas do
begin
if NewStyle then
begin
Brush.Color := clBtnFace;
Brush.Style := bsSolid;
DC := Canvas.Handle; { Reduce calls to GetHandle }
if IsDown then
begin { DrawEdge is faster than Polyline }
DrawEdge(DC, R, BDR_SUNKENINNER, BF_TOPLEFT); { black }
DrawEdge(DC, R, BDR_SUNKENOUTER, BF_BOTTOMRIGHT); { btnhilite }
Dec(R.Bottom);
Dec(R.Right);
Inc(R.Top);
Inc(R.Left);
DrawEdge(DC, R, BDR_SUNKENOUTER, BF_TOPLEFT or BF_MIDDLE); { btnshadow }
end
else
begin
DrawEdge(DC, R, BDR_RAISEDOUTER, BF_BOTTOMRIGHT); { black }
Dec(R.Bottom);
Dec(R.Right);
DrawEdge(DC, R, BDR_RAISEDINNER, BF_TOPLEFT); { btnhilite }
Inc(R.Top);
Inc(R.Left);
DrawEdge(DC, R, BDR_RAISEDINNER, BF_BOTTOMRIGHT or BF_MIDDLE); { btnshadow }
end;
end
else
begin
Pen.Color := clWindowFrame;
Brush.Color := clBtnFace;
Brush.Style := bsSolid;
Rectangle(R.Left, R.Top, R.Right, R.Bottom);
{ round the corners - only applies to Win 3.1 style buttons }
if IsRounded then
begin
Pixels[R.Left, R.Top] := clBtnFace;
Pixels[R.Left, R.Bottom - 1] := clBtnFace;
Pixels[R.Right - 1, R.Top] := clBtnFace;
Pixels[R.Right - 1, R.Bottom - 1] := clBtnFace;
end;
if IsFocused then
begin
InflateRect(R, -1, -1);
Brush.Style := bsClear;
Rectangle(R.Left, R.Top, R.Right, R.Bottom);
end;
InflateRect(R, -1, -1);
if not IsDown then
Frame3D(Canvas, R, clBtnHighlight, clBtnShadow, BevelWidth)
else
begin
Pen.Color := clBtnShadow;
PolyLine([Point(R.Left, R.Bottom - 1), Point(R.Left, R.Top),
Point(R.Right, R.Top)]);
end;
end;
end;
Result := Rect(Client.Left + 1, Client.Top + 1,
Client.Right - 2, Client.Bottom - 2);
if IsDown then OffsetRect(Result, 1, 1);
end;
procedure Register;
begin
RegisterComponents('Additional', [TOnOffBtn]);
end;
{TGlyph Stuff mostly unchanged excep references to TOnOffBtnXXXX types}
type
TGlyphList = class(TImageList)
private
Used: TBits;
FCount: Integer;
function AllocateIndex: Integer;
public
constructor CreateSize(AWidth, AHeight: Integer);
destructor Destroy; override;
function AddMasked(Image: TBitmap; MaskColor: TColor): Integer;
procedure Delete(Index: Integer);
property Count: Integer read FCount;
end;
TGlyphCache = class
private
GlyphLists: TList;
public
constructor Create;
destructor Destroy; override;
function GetList(AWidth, AHeight: Integer): TGlyphList;
procedure ReturnList(List: TGlyphList);
function Empty: Boolean;
end;
TButtonGlyph = class
private
FOriginal: TBitmap;
FGlyphList: TGlyphList;
FIndexs: array[TOnOffBtnState] of Integer;
FTransparentColor: TColor;
FNumGlyphs: TOnOffBtnNumGlyphs;
FOnChange: TNotifyEvent;
procedure GlyphChanged(Sender: TObject);
procedure SetGlyph(Value: TBitmap);
procedure SetNumGlyphs(Value: TOnOffBtnNumGlyphs);
procedure Invalidate;
function CreateButtonGlyph(State: TOnOffBtnState): Integer;
procedure DrawButtonGlyph(Canvas: TCanvas; const GlyphPos: TPoint;
State: TOnOffBtnState; Transparent: Boolean);
procedure DrawButtonText(Canvas: TCanvas; const Caption: string;
TextBounds: TRect; State: TOnOffBtnState; BiDiFlags: Longint);
procedure CalcButtonLayout(Canvas: TCanvas; const Client: TRect;
const Offset: TPoint; const Caption: string; Layout: TOnOffBtnLayout;
Margin, Spacing: Integer; var GlyphPos: TPoint; var TextBounds: TRect;
BiDiFlags: Longint);
public
constructor Create;
destructor Destroy; override;
{ return the text rectangle }
function Draw(Canvas: TCanvas; const Client: TRect; const Offset: TPoint;
const Caption: string; Layout: TOnOffBtnLayout; Margin, Spacing: Integer;
State: TOnOffBtnState; Transparent: Boolean; BiDiFlags: Longint): TRect;
property Glyph: TBitmap read FOriginal write SetGlyph;
property NumGlyphs: TOnOffBtnNumGlyphs read FNumGlyphs write SetNumGlyphs;
property OnChange: TNotifyEvent read FOnChange write FOnChange;
end;
{ TGlyphList
Unchanged for Buttons.pas}
constructor TGlyphList.CreateSize(AWidth, AHeight: Integer);
begin
inherited CreateSize(AWidth, AHeight);
Used := TBits.Create;
end;
destructor TGlyphList.Destroy;
begin
Used.Free;
inherited Destroy;
end;
function TGlyphList.AllocateIndex: Integer;
begin
Result := Used.OpenBit;
if Result >= Used.Size then
begin
Result := inherited Add(nil, nil);
Used.Size := Result + 1;
end;
Used[Result] := True;
end;
function TGlyphList.AddMasked(Image: TBitmap; MaskColor: TColor): Integer;
begin
Result := AllocateIndex;
ReplaceMasked(Result, Image, MaskColor);
Inc(FCount);
end;
procedure TGlyphList.Delete(Index: Integer);
begin
if Used[Index] then
begin
Dec(FCount);
Used[Index] := False;
end;
end;
{ TGlyphCache
unchanged fro Buttons.pas }
constructor TGlyphCache.Create;
begin
inherited Create;
GlyphLists := TList.Create;
end;
destructor TGlyphCache.Destroy;
begin
GlyphLists.Free;
inherited Destroy;
end;
function TGlyphCache.GetList(AWidth, AHeight: Integer): TGlyphList;
var
I: Integer;
begin
for I := GlyphLists.Count - 1 downto 0 do
begin
Result := GlyphLists[I];
with Result do
if (AWidth = Width) and (AHeight = Height) then Exit;
end;
Result := TGlyphList.CreateSize(AWidth, AHeight);
GlyphLists.Add(Result);
end;
procedure TGlyphCache.ReturnList(List: TGlyphList);
begin
if List = nil then
Exit;
if List.Count = 0 then begin
GlyphLists.Remove(List);
List.Free;
end;
end;
function TGlyphCache.Empty: Boolean;
begin
Result := GlyphLists.Count = 0;
end;
var
GlyphCache: TGlyphCache = nil;
ButtonCount: Integer = 0;
{ TButtonGlyph
Changed }
constructor TButtonGlyph.Create;
var
I: TOnOffBtnState;
begin
inherited Create;
FOriginal := TBitmap.Create;
FOriginal.OnChange := GlyphChanged;
FTransparentColor := clOlive;
FNumGlyphs := 1;
for I := Low(I) to High(I) do
FIndexs[I] := -1;
if GlyphCache = nil then GlyphCache := TGlyphCache.Create;
end;
destructor TButtonGlyph.Destroy;
begin
FOriginal.Free;
Invalidate;
if Assigned(GlyphCache) and GlyphCache.Empty then
begin
GlyphCache.Free;
GlyphCache := nil;
end;
inherited Destroy;
end;
procedure TButtonGlyph.Invalidate;
var
I: TOnOffBtnState;
begin
for I := Low(I) to High(I) do
begin
if FIndexs[I] <> -1 then FGlyphList.Delete(FIndexs[I]);
FIndexs[I] := -1;
end;
GlyphCache.ReturnList(FGlyphList);
FGlyphList := nil;
end;
procedure TButtonGlyph.GlyphChanged(Sender: TObject);
begin
if Sender = FOriginal then
begin
FTransparentColor := FOriginal.TransparentColor;
Invalidate;
if Assigned(FOnChange) then FOnChange(Self);
end;
end;
procedure TButtonGlyph.SetGlyph(Value: TBitmap);
var
Glyphs: Integer;
begin
Invalidate;
FOriginal.Assign(Value);
if (Value <> nil) and (Value.Height > 0) then
begin
FTransparentColor := Value.TransparentColor;
if Value.Width mod Value.Height = 0 then
begin
Glyphs := Value.Width div Value.Height;
if Glyphs > 4 then Glyphs := 1;
SetNumGlyphs(Glyphs);
end;
end;
end;
procedure TButtonGlyph.SetNumGlyphs(Value: TOnOffBtnNumGlyphs);
begin
if (Value <> FNumGlyphs) and
(Value > 0) then begin
Invalidate;
FNumGlyphs := Value;
GlyphChanged(Glyph);
end;
end;
{The Core}
function TButtonGlyph.CreateButtonGlyph(State: TOnOffBtnState): Integer;
const
ROP_DSPDxax = $00E20746;
var
TmpImage, DDB, MonoBmp: TBitmap;
IWidth, IHeight: Integer;
IRect, ORect: TRect;
I: TOnOffBtnState;
DestDC: HDC;
begin
Result := FIndexs[State];
if Result <> -1 then
Exit;
if (FOriginal.Width or
FOriginal.Height) = 0 then
Exit;
IWidth := FOriginal.Width div FNumGlyphs;
IHeight := FOriginal.Height;
if FGlyphList = nil then begin
if GlyphCache = nil then
GlyphCache := TGlyphCache.Create;
FGlyphList := GlyphCache.GetList(IWidth, IHeight);
end;
TmpImage := TBitmap.Create;
try
TmpImage.Width := IWidth;
TmpImage.Height := IHeight;
IRect := Rect(0, 0, IWidth, IHeight);
TmpImage.Canvas.Brush.Color := clBtnFace;
TmpImage.Palette := CopyPalette(FOriginal.Palette);
I := State;
ORect := Rect(Ord(I) * IWidth, 0, (Ord(I) + 1) * IWidth, IHeight);
TmpImage.Canvas.CopyRect(IRect, FOriginal.Canvas, ORect);
case State of
bsOn, bsOff:
begin
TmpImage.Canvas.CopyRect(IRect, FOriginal.Canvas, ORect);
if FOriginal.TransparentMode = tmFixed then
FIndexs[State] := FGlyphList.AddMasked(TmpImage, FTransparentColor)
else
FIndexs[State] := FGlyphList.AddMasked(TmpImage, clDefault);
end;
bsDisabledOn,bsDisabledOff:
begin
MonoBmp := nil;
DDB := nil;
try
MonoBmp := TBitmap.Create;
DDB := TBitmap.Create;
DDB.Assign(FOriginal);
DDB.HandleType := bmDDB;
if NumGlyphs > 1 then
with TmpImage.Canvas do begin { Change white & gray to clBtnHighlight and clBtnShadow }
CopyRect(IRect, DDB.Canvas, ORect);
MonoBmp.Monochrome := True;
MonoBmp.Width := IWidth;
MonoBmp.Height := IHeight;
{ Convert white to clBtnHighlight }
DDB.Canvas.Brush.Color := clWhite;
MonoBmp.Canvas.CopyRect(IRect, DDB.Canvas, ORect);
Brush.Color := clBtnHighlight;
DestDC := Handle;
SetTextColor(DestDC, clBlack);
SetBkColor(DestDC, clWhite);
BitBlt(DestDC, 0, 0, IWidth, IHeight,
MonoBmp.Canvas.Handle, 0, 0, ROP_DSPDxax);
{ Convert gray to clBtnShadow }
DDB.Canvas.Brush.Color := clGray;
MonoBmp.Canvas.CopyRect(IRect, DDB.Canvas, ORect);
Brush.Color := clBtnShadow;
DestDC := Handle;
SetTextColor(DestDC, clBlack);
SetBkColor(DestDC, clWhite);
BitBlt(DestDC, 0, 0, IWidth, IHeight,
MonoBmp.Canvas.Handle, 0, 0, ROP_DSPDxax);
{ Convert transparent color to clBtnFace }
DDB.Canvas.Brush.Color := ColorToRGB(FTransparentColor);
MonoBmp.Canvas.CopyRect(IRect, DDB.Canvas, ORect);
Brush.Color := clBtnFace;
DestDC := Handle;
SetTextColor(DestDC, clBlack);
SetBkColor(DestDC, clWhite);
BitBlt(DestDC, 0, 0, IWidth, IHeight,
MonoBmp.Canvas.Handle, 0, 0, ROP_DSPDxax);
end
else begin
{ Create a disabled version }
with MonoBmp do begin
Assign(FOriginal);
HandleType := bmDDB;
Canvas.Brush.Color := clBlack;
Width := IWidth;
if Monochrome then begin
Canvas.Font.Color := clWhite;
Monochrome := False;
Canvas.Brush.Color := clWhite;
end;
Monochrome := True;
end;
with TmpImage.Canvas do begin
Brush.Color := clBtnFace;
FillRect(IRect);
Brush.Color := clBtnHighlight;
SetTextColor(Handle, clBlack);
SetBkColor(Handle, clWhite);
BitBlt(Handle, 1, 1, IWidth, IHeight,
MonoBmp.Canvas.Handle, 0, 0, ROP_DSPDxax);
Brush.Color := clBtnShadow;
SetTextColor(Handle, clBlack);
SetBkColor(Handle, clWhite);
BitBlt(Handle, 0, 0, IWidth, IHeight,
MonoBmp.Canvas.Handle, 0, 0, ROP_DSPDxax);
end;
end;
finally
DDB.Free;
MonoBmp.Free;
end;
FIndexs[State] := FGlyphList.AddMasked(TmpImage, clDefault);
end;
end;
finally
TmpImage.Free;
end;
Result := FIndexs[State];
FOriginal.Dormant;
end;
procedure TButtonGlyph.DrawButtonGlyph(Canvas: TCanvas; const GlyphPos: TPoint;
State: TOnOffBtnState; Transparent: Boolean);
var
Index: Integer;
begin
if FOriginal = nil then
Exit;
if (FOriginal.Width = 0) or
(FOriginal.Height = 0) then
Exit;
Index := CreateButtonGlyph(State);
with GlyphPos do
if Transparent then
ImageList_DrawEx(FGlyphList.Handle, Index, Canvas.Handle, X, Y, 0, 0,
clNone, clNone, ILD_Transparent)
else
ImageList_DrawEx(FGlyphList.Handle, Index, Canvas.Handle, X, Y, 0, 0,
ColorToRGB(clBtnFace), clNone, ILD_Normal);
end;
procedure TButtonGlyph.DrawButtonText(Canvas: TCanvas; const Caption: string;
TextBounds: TRect; State: TOnOffBtnState; BiDiFlags: LongInt);
begin
with Canvas do begin
Brush.Style := bsClear;
if State in [bsDisabledOn, bsDisabledOff] then begin
OffsetRect(TextBounds, 1, 1);
Font.Color := clBtnHighlight;
DrawText(Handle, PChar(Caption), Length(Caption), TextBounds,
DT_CENTER or DT_VCENTER or BiDiFlags);
OffsetRect(TextBounds, -1, -1);
Font.Color := clBtnShadow;
DrawText(Handle, PChar(Caption), Length(Caption), TextBounds,
DT_CENTER or DT_VCENTER or BiDiFlags);
end
else
DrawText(Handle, PChar(Caption), Length(Caption), TextBounds,
DT_CENTER or DT_VCENTER or BiDiFlags);
end;
end;
procedure TButtonGlyph.CalcButtonLayout(Canvas: TCanvas; const Client: TRect;
const Offset: TPoint; const Caption: string; Layout: TOnOffBtnLayout; Margin,
Spacing: Integer; var GlyphPos: TPoint; var TextBounds: TRect;
BiDiFlags: LongInt);
var
TextPos: TPoint;
ClientSize, GlyphSize, TextSize: TPoint;
TotalSize: TPoint;
begin
if (BiDiFlags and DT_RIGHT) = DT_RIGHT then
if Layout = blGlyphLeft then
Layout := blGlyphRight
else
if Layout = blGlyphRight then
Layout := blGlyphLeft;
{ calculate the item sizes }
ClientSize := Point(Client.Right - Client.Left, Client.Bottom -
Client.Top);
if FOriginal <> nil then
GlyphSize := Point(FOriginal.Width div FNumGlyphs, FOriginal.Height)
else
GlyphSize := Point(0, 0);
if Length(Caption) > 0 then begin
TextBounds := Rect(0, 0, Client.Right - Client.Left, 0);
DrawText(Canvas.Handle, PChar(Caption), Length(Caption), TextBounds,
DT_CALCRECT or BiDiFlags);
TextSize := Point(TextBounds.Right - TextBounds.Left, TextBounds.Bottom -
TextBounds.Top);
end
else begin
TextBounds := Rect(0, 0, 0, 0);
TextSize := Point(0,0);
end;
{ If the layout has the glyph on the right or the left, then both the
text and the glyph are centered vertically. If the glyph is on the top
or the bottom, then both the text and the glyph are centered horizontally.}
if Layout in [blGlyphLeft, blGlyphRight] then begin
GlyphPos.Y := (ClientSize.Y - GlyphSize.Y + 1) div 2;
TextPos.Y := (ClientSize.Y - TextSize.Y + 1) div 2;
end
else begin
GlyphPos.X := (ClientSize.X - GlyphSize.X + 1) div 2;
TextPos.X := (ClientSize.X - TextSize.X + 1) div 2;
end;
{ if there is no text or no bitmap, then Spacing is irrelevant }
if (TextSize.X = 0) or (GlyphSize.X = 0) then
Spacing := 0;
{ adjust Margin and Spacing }
if Margin = -1 then begin
if Spacing = -1 then begin
TotalSize := Point(GlyphSize.X + TextSize.X, GlyphSize.Y + TextSize.Y);
if Layout in [blGlyphLeft, blGlyphRight] then
Margin := (ClientSize.X - TotalSize.X) div 3
else
Margin := (ClientSize.Y - TotalSize.Y) div 3;
Spacing := Margin;
end
else begin
TotalSize := Point(GlyphSize.X + Spacing + TextSize.X, GlyphSize.Y +
Spacing + TextSize.Y);
if Layout in [blGlyphLeft, blGlyphRight] then
Margin := (ClientSize.X - TotalSize.X + 1) div 2
else
Margin := (ClientSize.Y - TotalSize.Y + 1) div 2;
end;
end
else begin
if Spacing = -1 then begin
TotalSize := Point(ClientSize.X - (Margin + GlyphSize.X), ClientSize.Y -
(Margin + GlyphSize.Y));
if Layout in [blGlyphLeft, blGlyphRight] then
Spacing := (TotalSize.X - TextSize.X) div 2
else
Spacing := (TotalSize.Y - TextSize.Y) div 2;
end;
end;
case Layout of
blGlyphLeft:
begin
GlyphPos.X := Margin;
TextPos.X := GlyphPos.X + GlyphSize.X + Spacing;
end;
blGlyphRight:
begin
GlyphPos.X := ClientSize.X - Margin - GlyphSize.X;
TextPos.X := GlyphPos.X - Spacing - TextSize.X;
end;
blGlyphTop:
begin
GlyphPos.Y := Margin;
TextPos.Y := GlyphPos.Y + GlyphSize.Y + Spacing;
end;
blGlyphBottom:
begin
GlyphPos.Y := ClientSize.Y - Margin - GlyphSize.Y;
TextPos.Y := GlyphPos.Y - Spacing - TextSize.Y;
end;
end;
{ fixup the result variables }
with GlyphPos do begin
Inc(X, Client.Left + Offset.X);
Inc(Y, Client.Top + Offset.Y);
end;
OffsetRect(TextBounds, TextPos.X + Client.Left + Offset.X,
TextPos.Y + Client.Top + Offset.X);
end;
function TButtonGlyph.Draw(Canvas: TCanvas; const Client: TRect;
const Offset: TPoint; const Caption: string; Layout: TOnOffBtnLayout;
Margin, Spacing: Integer; State: TOnOffBtnState; Transparent: Boolean;
BiDiFlags: LongInt): TRect;
var
GlyphPos: TPoint;
begin
CalcButtonLayout(Canvas, Client, Offset, Caption, Layout, Margin, Spacing,
GlyphPos, Result, BiDiFlags);
DrawButtonGlyph(Canvas, GlyphPos, State, Transparent);
DrawButtonText(Canvas, Caption, Result, State, BiDiFlags);
end;
{TOnOffBtnActionLink}
procedure TOnOffBtnActionLink.AssignClient(AClient: TObject);
begin
inherited AssignClient(AClient);
FClient := AClient as TOnOffBtn;
end;
function TOnOffBtnActionLink.IsCheckedLinked: Boolean;
begin
Result := inherited IsCheckedLinked and (FClient.GroupIndex <> 0) and
FClient.OnOff and (FClient.OnOff = (Action as TCustomAction).Checked);
end;
function TOnOffBtnActionLink.IsGroupIndexLinked: Boolean;
begin
Result := (FClient is TOnOffBtn) and
(TOnOffBtn(FClient).GroupIndex = (Action as TCustomAction).GroupIndex);
end;
procedure TOnOffBtnActionLink.SetChecked(Value: Boolean);
begin
if IsCheckedLinked then TOnOffBtn(FClient).OnOff:= Value;
end;
procedure TOnOffBtnActionLink.SetGroupIndex(Value: Integer);
begin
if IsGroupIndexLinked then TOnOffBtn(FClient).GroupIndex := Value;
end;
{ TOnOffBtn }
constructor TOnOffBtn.Create(AOwner: TComponent);
begin
FGlyph := TButtonGlyph.Create;
TButtonGlyph(FGlyph).OnChange := GlyphChanged;
inherited Create(AOwner);
SetBounds(0, 0, 25, 25);
ControlStyle := [csCaptureMouse, csDoubleClicks];
ParentFont := True;
Color := clBtnFace;
FSpacing := 1;
FMargin := -1;
NumGlyphs := 4;
OnOff := False;
FLayout := blGlyphTop;
FTransparent := True;
{Load the default Glyph Note that I use LoadFromResourceID this is becaulse
it supports loading a 256 color bitmap.}
TButtonGlyph(FGlyph).Glyph.LoadFromResourceID(HInstance , 1);
Inc(ButtonCount);
end;
procedure TOnOffBtn.Paint;
const
DownStyles: array[Boolean] of Integer = (BDR_RAISEDINNER, BDR_SUNKENOUTER);
FillStyles: array[Boolean] of Integer = (BF_MIDDLE, 0);
var
PaintRect: TRect;
DrawFlags: Integer;
Offset: TPoint;
begin
Canvas.Font := Self.Font;
PaintRect := Rect(0, 0, Width, Height);
if not FFlat then begin
DrawFlags := DFCS_BUTTONPUSH or DFCS_ADJUSTRECT;
if FState in [bsON, bsDisabledON] then
DrawFlags := DrawFlags or DFCS_PUSHED;
DrawFrameControl(Canvas.Handle, PaintRect, DFC_BUTTON, DrawFlags);
end
else begin
if (FState in [bsON, bsDisabledON]) or
(FState in [bsOFF, bsDisabledOFF]) or
(FMouseInControl and
(FState <> bsDisabledON) or
(FState <> bsDisabledOFF)) or
(csDesigning in ComponentState) then
DrawEdge(Canvas.Handle, PaintRect, DownStyles[FState in [bsON, bsDisabledON]],
FillStyles[Transparent] or BF_RECT)
else
if not Transparent then begin
Canvas.Brush.Color := Color;
Canvas.FillRect(PaintRect);
end;
InflateRect(PaintRect, -1, -1);
end;
if FState in [bsON, bsDisabledON] then begin
if (FState = bsDisabledON) and
(not FFlat or not FMouseInControl) then begin
Canvas.Brush.Bitmap := AllocPatternBitmap(clBtnFace, clBtnHighlight);
Canvas.FillRect(PaintRect);
end;
Offset.X := 1;
Offset.Y := 1;
end
else begin
Offset.X := 0;
Offset.Y := 0;
end;
TButtonGlyph(FGlyph).Draw(Canvas, PaintRect, Offset, Caption, FLayout, FMargin,
FSpacing, FState, Transparent, DrawTextBiDiModeFlags(0));
end;
function TOnOffBtn.GetGlyph: TBitmap;
begin
Result := TButtonGlyph(FGlyph).Glyph;
end;
procedure TOnOffBtn.SetGlyph(Value: TBitmap);
begin
TButtonGlyph(FGlyph).Glyph := Value;
Invalidate;
end;
function TOnOffBtn.GetNumGlyphs: TOnOffBtnNumGlyphs;
begin
Result := TButtonGlyph(FGlyph).NumGlyphs;
end;
procedure TOnOffBtn.SetNumGlyphs(Value: TOnOffBtnNumGlyphs);
begin
if Value < 0 then
Value := 1
else
if Value > 4 then
Value := 4;
if Value <> TButtonGlyph(FGlyph).NumGlyphs then begin
TButtonGlyph(FGlyph).NumGlyphs := Value;
Invalidate;
end;
end;
procedure TOnOffBtn.GlyphChanged(Sender: TObject);
begin
Invalidate;
end;
procedure TOnOffBtn.UpdateExclusive;
var
Msg: TMessage;
begin
if (FGroupIndex <> 0) and (Parent <> nil) then
begin
Msg.Msg := CM_BUTTONPRESSED;
Msg.WParam := FGroupIndex;
Msg.LParam := Longint(Self);
Msg.Result := 0;
Parent.Broadcast(Msg);
end;
end;
procedure TOnOffBtn.SetOnOff(Value: Boolean);
begin
{if Value then OFF}
if Value <> FOnOff then begin
FOnOff := Value;
if Value then begin
if Enabled then
FState := bsON
else
FState := bsDisabledON;
Repaint;
end
else begin
if Enabled then
FState := bsOFF
else
FState := bsDisabledOFF;
Repaint;
end;
UpdateExclusive;
end;
end;
procedure TOnOffBtn.SetFlat(Value: Boolean);
begin
if Value <> FFlat then begin
FFlat := Value;
Invalidate;
end;
end;
procedure TOnOffBtn.SetGroupIndex(Value: Integer);
begin
if FGroupIndex <> Value then begin
FGroupIndex := Value;
UpdateExclusive;
end;
end;
procedure TOnOffBtn.SetLayout(Value: TOnOffBtnLayout);
begin
if FLayout <> Value then begin
FLayout := Value;
Invalidate;
end;
end;
procedure TOnOffBtn.SetMargin(Value: Integer);
begin
if (Value <> FMargin) and
(Value >= -1) then begin
FMargin := Value;
Invalidate;
end;
end;
procedure TOnOffBtn.SetSpacing(Value: Integer);
begin
if Value <> FSpacing then begin
FSpacing := Value;
Invalidate;
end;
end;
procedure TOnOffBtn.SetTransparent(Value: Boolean);
begin
if Value <> FTransparent then begin
FTransparent := Value;
if Value then
ControlStyle := ControlStyle - [csOpaque]
else
ControlStyle := ControlStyle + [csOpaque];
Invalidate;
end;
end;
(*
procedure TOnOffBtn.SetAllowAllUp(Value: Boolean);
begin
if FAllowAllUp <> Value then
begin
FAllowAllUp := Value;
UpdateExclusive;
end;
end;
*)
procedure TOnOffBtn.WMLButtonDblClk(var Message: TWMLButtonDown);
begin
inherited;
if Enabled then
DblClick;
end;
procedure TOnOffBtn.CMEnabledChanged(var Message: TMessage);
begin
if Enabled then begin
if FOnOff then
FState := bsON
else
FState := bsOFF;
end
else begin
if FOnOff then
FState := bsDisabledON
else
FState := bsDisabledOFF;
end;
TButtonGlyph(FGlyph).CreateButtonGlyph(FState);
UpdateTracking;
Repaint;
end;
procedure TOnOffBtn.CMButtonPressed(var Message: TMessage);
var
Sender: TOnOffBtn;
begin
if Message.WParam = FGroupIndex then begin
Sender := TOnOffBtn(Message.LParam);
if Sender <> Self then begin
FOnOff := not Sender.OnOff;
if Enabled then begin
if FOnOff then
FState := bsON
else
FState := bsOFF
end
else begin
if FOnOff then
FState := bsON
else
FState := bsOFF
end;
if (Action is TCustomAction) then
TCustomAction(Action).Checked := False;
Invalidate;
end;
end;
end;
procedure TOnOffBtn.CMDialogChar(var Message: TCMDialogChar);
begin
with Message do
if IsAccel(CharCode, Caption) and Enabled and Visible and
(Parent <> nil) and Parent.Showing then begin
Click;
Result := 1;
end
else
inherited;
end;
procedure TOnOffBtn.CMFontChanged(var Message: TMessage);
begin
Invalidate;
end;
procedure TOnOffBtn.CMTextChanged(var Message: TMessage);
begin
Invalidate;
end;
procedure TOnOffBtn.CMSysColorChange(var Message: TMessage);
begin
with TButtonGlyph(FGlyph) do begin
Invalidate;
CreateButtonGlyph(FState);
end;
end;
procedure TOnOffBtn.CMMouseEnter(var Message: TMessage);
begin
inherited;
{ Don't draw a border if DragMode <> dmAutomatic since this button is meant to
be used as a dock client. }
if FFlat and
not FMouseInControl and
Enabled and
(DragMode <> dmAutomatic) and
(GetCapture = 0) then begin
FMouseInControl := True;
Repaint;
end;
end;
procedure TOnOffBtn.CMMouseLeave(var Message: TMessage);
begin
inherited;
if FFlat and
FMouseInControl and
Enabled and
not FDragging then begin
FMouseInControl := False;
Invalidate;
end;
end;
procedure TOnOffBtn.ActionChange(Sender: TObject; CheckDefaults: Boolean);
procedure CopyImage(ImageList: TCustomImageList; Index: Integer);
begin
with Glyph do begin
Width := ImageList.Width;
Height := ImageList.Height;
Canvas.Brush.Color := clFuchsia;//! for lack of a better color
Canvas.FillRect(Rect(0,0, Width, Height));
ImageList.Draw(Canvas, 0, 0, Index);
end;
end;
begin
inherited ActionChange(Sender, CheckDefaults);
if Sender is TCustomAction then
with TCustomAction(Sender) do begin
if CheckDefaults or (Self.GroupIndex = 0) then
Self.GroupIndex := GroupIndex;
{ Copy image from action's imagelist }
if (Glyph.Empty) and (ActionList <> nil) and (ActionList.Images <> nil) and
(ImageIndex >= 0) and (ImageIndex < ActionList.Images.Count) then
CopyImage(ActionList.Images, ImageIndex);
end;
end;
procedure TOnOffBtn.UpdateTracking;
var
P: TPoint;
begin
if FFlat then begin
if Enabled then begin
GetCursorPos(P);
FMouseInControl := not (FindDragTarget(P, True) = Self);
if FMouseInControl then
Perform(CM_MOUSELEAVE, 0, 0)
else
Perform(CM_MOUSEENTER, 0, 0);
end;
end;
end;
procedure TOnOffBtn.Loaded;
var
State: TOnOffBtnState;
begin
inherited Loaded;
if Enabled then begin
if FOnOff then
State := bsON
else
State := bsOFF
end
else begin
if FOnOff then
State := bsDisabledON
else
State := bsDisabledOFF
end;
TButtonGlyph(FGlyph).CreateButtonGlyph(State);
end;
function TOnOffBtn.GetActionLinkClass: TControlActionLinkClass;
begin
Result := TOnOffBtnActionLink;
end;
function TOnOffBtn.GetPalette: HPALETTE;
begin
Result := Glyph.Palette;
end;
procedure TOnOffBtn.MouseDown(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer);
begin
inherited MouseDown(Button, Shift, X, Y);
if (Button = mbLeft) and
Enabled then begin
if FOnOff then begin // ON
FState := bsOFF;
Invalidate;
end
else begin
FState := bsON;
Invalidate;
end;
FDragging := True;
end;
end;
procedure TOnOffBtn.MouseMove(Shift: TShiftState; X, Y: Integer);
var
NewState: TOnOffBtnState;
begin
inherited MouseMove(Shift, X, Y);
if FDragging then begin
{use the disabled images for the drag image}
if FOnOff then // ON
NewState := bsDisabledON
else
NewState := bsDisabledOFF;
if (X >= 0) and
(X < ClientWidth) and
(Y >= 0) and
(Y <= ClientHeight) then
if FOnOff then
NewState := bsON
else
NewState := bsOFF;
if NewState <> FState then begin
FState := NewState;
Invalidate;
end;
end
else
if not FMouseInControl then
UpdateTracking;
end;
procedure TOnOffBtn.MouseUp(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer);
var
DoClick: Boolean;
begin
inherited MouseUp(Button, Shift, X, Y);
if FDragging then begin
FDragging := False;
DoClick := (X >= 0) and (X < ClientWidth) and (Y >= 0) and (Y <= ClientHeight);
if FGroupIndex = 0 then begin
{ Redraw face in-case mouse is captured }
if FState = bsDisabledOFF then begin
FState := bsOFF;
FOnOff := False;
end
else
if FState = bsDisabledON then begin
FState := bsON;
FOnOff := True;
end;
FMouseInControl := False;
if DoClick then // and not (FState in [bsDisabledON, bsON]) then
Invalidate
else
Repaint;
end
else
if DoClick then begin
SetOnOff(FOnOff);
Repaint;
end
else begin
Repaint;
end;
if DoClick then
Click;
UpdateTracking;
end;
end;
destructor TOnOffBtn.Destroy;
begin
Dec(ButtonCount);
inherited Destroy;
TButtonGlyph(FGlyph).Free;
end;
procedure TOnOffBtn.Click;
begin
inherited Click;
end;
end.
|
Sign Up
