1134 lines
30 KiB
ObjectPascal
1134 lines
30 KiB
ObjectPascal
unit CoolButton;
|
|
|
|
{$S-,W-,R-}
|
|
{$C PRELOAD}
|
|
|
|
interface
|
|
|
|
uses Windows, Messages, Classes, Controls, Forms, Graphics, StdCtrls,
|
|
ExtCtrls, CommCtrl;
|
|
|
|
type
|
|
TButtonLayout = (blGlyphLeft, blGlyphRight, blGlyphTop, blGlyphBottom);
|
|
TButtonState = (bsUp, bsDisabled, bsDown, bsExclusive);
|
|
TButtonStyle = (bsAutoDetect, bsWin31, bsNew);
|
|
TNumGlyphs = 1..4;
|
|
|
|
TCoolButton = class(TGraphicControl)
|
|
private
|
|
FGroupIndex: Integer;
|
|
FGlyph: Pointer;
|
|
FDown: Boolean;
|
|
FDragging: Boolean;
|
|
FAllowAllUp: Boolean;
|
|
FLayout: TButtonLayout;
|
|
FSpacing: Integer;
|
|
FMargin: Integer;
|
|
FMouseInControl: Boolean;
|
|
// FMouseinMask: Boolean;
|
|
procedure GlyphChanged(Sender: TObject);
|
|
procedure UpdateExclusive;
|
|
function GetGlyph: TBitmap;
|
|
procedure SetGlyph(Value: TBitmap);
|
|
function GetNumGlyphs: TNumGlyphs;
|
|
procedure SetNumGlyphs(Value: TNumGlyphs);
|
|
procedure SetDown(Value: Boolean);
|
|
procedure SetAllowAllUp(Value: Boolean);
|
|
procedure SetGroupIndex(Value: Integer);
|
|
procedure SetLayout(Value: TButtonLayout);
|
|
procedure SetSpacing(Value: Integer);
|
|
procedure SetMargin(Value: Integer);
|
|
procedure UpdateTracking;
|
|
procedure WMLButtonDblClk(var Message: TWMLButtonDown); message WM_LBUTTONDBLCLK;
|
|
procedure CMEnabledChanged(var Message: TMessage); message CM_ENABLEDCHANGED;
|
|
procedure CMButtonPressed(var Message: TMessage); message CM_BUTTONPRESSED;
|
|
procedure CMDialogChar(var Message: TCMDialogChar); message CM_DIALOGCHAR;
|
|
procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
|
|
procedure CMTextChanged(var Message: TMessage); message CM_TEXTCHANGED;
|
|
procedure CMSysColorChange(var Message: TMessage); message CM_SYSCOLORCHANGE;
|
|
procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE;
|
|
procedure WMEraseBkgnd( var message:TWMEraseBkgnd); message WM_ERASEBKGND;
|
|
procedure WMPaint( var message:TWMPaint); message WM_PAINT;
|
|
procedure WMNCPaint( var message:TWMNCPaint); message WM_NCPAINT;
|
|
protected
|
|
FState: TButtonState;
|
|
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;
|
|
public
|
|
constructor Create(AOwner: TComponent); override;
|
|
destructor Destroy; override;
|
|
procedure Click; override;
|
|
published
|
|
property AllowAllUp: Boolean read FAllowAllUp write SetAllowAllUp default False;
|
|
property GroupIndex: Integer read FGroupIndex write SetGroupIndex default 0;
|
|
property Down: Boolean read FDown write SetDown default False;
|
|
property Caption;
|
|
property Enabled;
|
|
property Font;
|
|
property Glyph: TBitmap read GetGlyph write SetGlyph;
|
|
property Layout: TButtonLayout read FLayout write SetLayout default blGlyphLeft;
|
|
property Margin: Integer read FMargin write SetMargin default -1;
|
|
property NumGlyphs: TNumGlyphs read GetNumGlyphs write SetNumGlyphs default 4;
|
|
property ParentFont;
|
|
property ParentShowHint;
|
|
property ShowHint;
|
|
property Spacing: Integer read FSpacing write SetSpacing default 4;
|
|
property Visible;
|
|
property OnClick;
|
|
property OnDblClick;
|
|
property OnMouseDown;
|
|
property OnMouseMove;
|
|
property OnMouseUp;
|
|
end;
|
|
|
|
function DrawButtonFace(Canvas: TCanvas; const Client: TRect;
|
|
BevelWidth: Integer; Style: TButtonStyle; IsRounded, IsDown,
|
|
IsFocused: Boolean): TRect;
|
|
|
|
procedure Register;
|
|
|
|
implementation
|
|
|
|
uses Consts, SysUtils;
|
|
|
|
|
|
procedure Register;
|
|
begin
|
|
RegisterComponents('Cool!', [TCoolButton]);
|
|
end;
|
|
|
|
|
|
|
|
{ DrawButtonFace - returns the remaining usable area inside the Client rect.}
|
|
function DrawButtonFace(Canvas: TCanvas; const Client: TRect;
|
|
BevelWidth: Integer; Style: TButtonStyle; 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;
|
|
|
|
|
|
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[TButtonState] of Integer;
|
|
FTransparentColor: TColor;
|
|
FNumGlyphs: TNumGlyphs;
|
|
FOnChange: TNotifyEvent;
|
|
procedure GlyphChanged(Sender: TObject);
|
|
procedure SetGlyph(Value: TBitmap);
|
|
procedure SetNumGlyphs(Value: TNumGlyphs);
|
|
procedure Invalidate;
|
|
function CreateButtonGlyph(State: TButtonState): Integer;
|
|
procedure DrawButtonGlyph(Canvas: TCanvas; const GlyphPos: TPoint;
|
|
State: TButtonState; Transparent: Boolean);
|
|
procedure DrawButtonText(Canvas: TCanvas; const Caption: string;
|
|
TextBounds: TRect; State: TButtonState);
|
|
procedure CalcButtonLayout(Canvas: TCanvas; const Client: TRect;
|
|
const Offset: TPoint; const Caption: string; Layout: TButtonLayout;
|
|
Margin, Spacing: Integer; var GlyphPos: TPoint; var TextBounds: TRect);
|
|
public
|
|
constructor Create;
|
|
destructor Destroy; override;
|
|
{ return the text rectangle }
|
|
function Draw(Canvas: TCanvas; const Client: TRect; const Offset: TPoint;
|
|
const Caption: string; Layout: TButtonLayout; Margin, Spacing: Integer;
|
|
State: TButtonState; Transparent: Boolean): TRect;
|
|
property Glyph: TBitmap read FOriginal write SetGlyph;
|
|
property NumGlyphs: TNumGlyphs read FNumGlyphs write SetNumGlyphs;
|
|
property OnChange: TNotifyEvent read FOnChange write FOnChange;
|
|
end;
|
|
|
|
{ TGlyphList }
|
|
|
|
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 }
|
|
|
|
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;
|
|
Pattern: TBitmap = nil;
|
|
ButtonCount: Integer = 0;
|
|
|
|
procedure CreateBrushPattern;
|
|
var
|
|
X, Y: Integer;
|
|
begin
|
|
Pattern := TBitmap.Create;
|
|
Pattern.Width := 8;
|
|
Pattern.Height := 8;
|
|
with Pattern.Canvas do
|
|
begin
|
|
Brush.Style := bsSolid;
|
|
Brush.Color := clBtnFace;
|
|
FillRect(Rect(0, 0, Pattern.Width, Pattern.Height));
|
|
for Y := 0 to 7 do
|
|
for X := 0 to 7 do
|
|
if (Y mod 2) = (X mod 2) then { toggles between even/odd pixles }
|
|
Pixels[X, Y] := clBtnHighlight; { on even/odd rows }
|
|
end;
|
|
end;
|
|
|
|
|
|
{ TButtonGlyph }
|
|
|
|
constructor TButtonGlyph.Create;
|
|
var
|
|
I: TButtonState;
|
|
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: TButtonState;
|
|
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: TNumGlyphs);
|
|
begin
|
|
if (Value <> FNumGlyphs) and (Value > 0) then
|
|
begin
|
|
Invalidate;
|
|
FNumGlyphs := Value;
|
|
GlyphChanged(Glyph);
|
|
end;
|
|
end;
|
|
|
|
function TButtonGlyph.CreateButtonGlyph(State: TButtonState): Integer;
|
|
const
|
|
ROP_DSPDxax = $00E20746;
|
|
var
|
|
TmpImage, DDB, MonoBmp: TBitmap;
|
|
IWidth, IHeight: Integer;
|
|
IRect, ORect: TRect;
|
|
I: TButtonState;
|
|
DestDC: HDC;
|
|
begin
|
|
if (State = bsDown) and (NumGlyphs < 3) then State := bsUp;
|
|
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;
|
|
if Ord(I) >= NumGlyphs then I := bsUp;
|
|
ORect := Rect(Ord(I) * IWidth, 0, (Ord(I) + 1) * IWidth, IHeight);
|
|
case State of
|
|
bsUp, bsDown,
|
|
bsExclusive:
|
|
begin
|
|
TmpImage.Canvas.CopyRect(IRect, FOriginal.Canvas, ORect);
|
|
if FOriginal.TransparentMode = tmFixed then
|
|
FIndexs[State] := FGlyphList.AddMasked(TmpImage, FTransparentColor)
|
|
else
|
|
FIndexs[State] := FGlyphList.AddMasked(TmpImage, clDefault);
|
|
end;
|
|
bsDisabled:
|
|
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: TButtonState; 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 or (State = bsExclusive) 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,
|
|
clNone, clNone, ILD_Transparent);
|
|
end;
|
|
|
|
procedure TButtonGlyph.DrawButtonText(Canvas: TCanvas; const Caption: string;
|
|
TextBounds: TRect; State: TButtonState);
|
|
begin
|
|
with Canvas do
|
|
begin
|
|
Brush.Style := bsClear;
|
|
if State = bsDisabled then
|
|
begin
|
|
OffsetRect(TextBounds, 1, 1);
|
|
Font.Color := clBtnHighlight;
|
|
DrawText(Handle, PChar(Caption), Length(Caption), TextBounds, 0);
|
|
OffsetRect(TextBounds, -1, -1);
|
|
Font.Color := clBtnShadow;
|
|
DrawText(Handle, PChar(Caption), Length(Caption), TextBounds, 0);
|
|
end else
|
|
DrawText(Handle, PChar(Caption), Length(Caption), TextBounds,
|
|
DT_CENTER or DT_VCENTER or DT_SINGLELINE);
|
|
end;
|
|
end;
|
|
|
|
procedure TButtonGlyph.CalcButtonLayout(Canvas: TCanvas; const Client: TRect;
|
|
const Offset: TPoint; const Caption: string; Layout: TButtonLayout; Margin,
|
|
Spacing: Integer; var GlyphPos: TPoint; var TextBounds: TRect);
|
|
var
|
|
TextPos: TPoint;
|
|
ClientSize, GlyphSize, TextSize: TPoint;
|
|
TotalSize: TPoint;
|
|
begin
|
|
{ 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);
|
|
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 Layout in [blGlyphLeft, blGlyphRight] then
|
|
begin
|
|
GlyphPos.Y := 0;
|
|
TextPos.Y := (ClientSize.Y - TextSize.Y + 1) div 2;
|
|
end
|
|
else
|
|
begin
|
|
GlyphPos.X := 0;
|
|
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: TButtonLayout;
|
|
Margin, Spacing: Integer; State: TButtonState; Transparent: Boolean): TRect;
|
|
var
|
|
GlyphPos: TPoint;
|
|
begin
|
|
CalcButtonLayout(Canvas, Client, Offset, Caption, Layout, Margin, Spacing,
|
|
GlyphPos, Result);
|
|
DrawButtonGlyph(Canvas, GlyphPos, State, Transparent);
|
|
DrawButtonText(Canvas, Caption, Result, State);
|
|
end;
|
|
|
|
{ TCoolButton }
|
|
|
|
constructor TCoolButton.Create(AOwner: TComponent);
|
|
begin
|
|
inherited Create(AOwner);
|
|
SetBounds(0, 0, 25, 25);
|
|
ControlStyle := [csCaptureMouse, csOpaque, csDoubleClicks];
|
|
FGlyph := TButtonGlyph.Create;
|
|
TButtonGlyph(FGlyph).OnChange := GlyphChanged;
|
|
ParentFont := True;
|
|
FSpacing := 4;
|
|
FMargin := -1;
|
|
FLayout := blGlyphLeft;
|
|
Inc(ButtonCount);
|
|
numglyphs:=4;
|
|
end;
|
|
|
|
destructor TCoolButton.Destroy;
|
|
begin
|
|
TButtonGlyph(FGlyph).Free;
|
|
Dec(ButtonCount);
|
|
if ButtonCount = 0 then
|
|
begin
|
|
Pattern.Free;
|
|
Pattern := nil;
|
|
end;
|
|
inherited Destroy;
|
|
end;
|
|
|
|
procedure TCoolButton.Paint;
|
|
const
|
|
DownStyles: array[Boolean] of Integer = (BDR_RAISEDINNER, BDR_SUNKENOUTER);
|
|
FillStyles: array[Boolean] of Integer = (0, 0);
|
|
var
|
|
PaintRect: TRect;
|
|
Offset: TPoint;
|
|
begin
|
|
{ if not Enabled then
|
|
begin
|
|
FState := bsDisabled;
|
|
FDragging := False;
|
|
end
|
|
else if FState = bsDisabled then
|
|
begin
|
|
if FDown and (GroupIndex <> 0) then
|
|
FState := bsExclusive
|
|
else
|
|
FState := bsUp;
|
|
end else
|
|
if FState<>bsDown then if FMouseIncontrol then FState:=bsExclusive else FState:=bsUp;
|
|
}
|
|
if Enabled then
|
|
begin
|
|
if FMouseInControl then
|
|
begin
|
|
if FState<>bsDown then FState:=bsExclusive;
|
|
end else Fstate:=bsUp;
|
|
end else FState:=bsDisabled;
|
|
Canvas.Font := Self.Font;
|
|
PaintRect := Rect(0, 0, Width, Height);
|
|
if (FState in [bsDown, bsExclusive]) or
|
|
(FMouseInControl and (FState <> bsDisabled)) or
|
|
(csDesigning in ComponentState) then
|
|
if csDesigning in ComponentState then DrawEdge(Canvas.Handle, PaintRect, DownStyles[FState in [bsDown, bsExclusive]],
|
|
FillStyles[true] or BF_RECT);
|
|
if FState in [bsDown, bsExclusive] then
|
|
begin
|
|
if (FState = bsExclusive) and (not FMouseInControl) then
|
|
begin
|
|
// if Pattern = nil then CreateBrushPattern;
|
|
// Canvas.Brush.Bitmap := Pattern;
|
|
// Canvas.FillRect(PaintRect);
|
|
end;
|
|
Offset.X := 0;
|
|
Offset.Y := 0;
|
|
end
|
|
else
|
|
begin
|
|
Offset.X := 0;
|
|
Offset.Y := 0;
|
|
end;
|
|
TButtonGlyph(FGlyph).Draw(Canvas, PaintRect, Offset, Caption, FLayout, FMargin,
|
|
FSpacing, FState,true);
|
|
end;
|
|
|
|
procedure TCoolButton.UpdateTracking;
|
|
var
|
|
P: TPoint;
|
|
begin
|
|
if Enabled then
|
|
begin
|
|
GetCursorPos(P);
|
|
FMouseInControl := not (FindDragTarget(P, True) = Self);
|
|
if FMouseInControl then
|
|
Perform(CM_MOUSELEAVE, 0, 0);
|
|
end;
|
|
end;
|
|
|
|
procedure TCoolButton.Loaded;
|
|
var
|
|
State: TButtonState;
|
|
begin
|
|
inherited Loaded;
|
|
if Enabled then
|
|
State := bsUp
|
|
else
|
|
State := bsDisabled;
|
|
TButtonGlyph(FGlyph).CreateButtonGlyph(State);
|
|
end;
|
|
|
|
procedure TCoolButton.MouseDown(Button: TMouseButton; Shift: TShiftState;
|
|
X, Y: Integer);
|
|
begin
|
|
inherited MouseDown(Button, Shift, X, Y);
|
|
if (Button = mbLeft) and Enabled then
|
|
begin
|
|
if not FDown then
|
|
begin
|
|
FState := bsDown;
|
|
Invalidate;
|
|
end;
|
|
FDragging := True;
|
|
end;
|
|
end;
|
|
|
|
procedure TCoolButton.MouseMove(Shift: TShiftState; X, Y: Integer);
|
|
var
|
|
NewState : TButtonState;
|
|
P, P2 : TPoint;
|
|
OldState : Boolean;
|
|
|
|
begin
|
|
OldState := FMouseInControl;
|
|
GetCursorPos(P);
|
|
P2 := ScreenToClient (P);
|
|
FMouseInControl := (TButtonGlyph(FGlyph).Glyph.Canvas.Pixels[P2.x, P2.y] <> TButtonGlyph(FGlyph).Glyph.Canvas.Pixels[0, Glyph.Height - 1]) and
|
|
(P2.X < Glyph.Width) and (P2.Y < Glyph.Height) and (FindDragTarget(P, True) = Self);
|
|
inherited MouseMove(Shift, X, Y);
|
|
if FDragging then
|
|
begin
|
|
if not FDown then NewState := bsUp
|
|
else NewState := bsExclusive;
|
|
if (X >= 0) and (X < ClientWidth) and (Y >= 0) and (Y <= ClientHeight) then
|
|
if FDown then NewState := bsExclusive else NewState := bsDown;
|
|
if (NewState <> FState) then
|
|
begin
|
|
FState := NewState;
|
|
end;
|
|
end;
|
|
If (OldState <> FMouseInControl) then Invalidate;
|
|
end;
|
|
|
|
procedure TCoolButton.MouseUp(Button: TMouseButton; Shift: TShiftState;
|
|
X, Y: Integer);
|
|
var
|
|
DoClick: Boolean;
|
|
begin
|
|
inherited MouseUp(Button, Shift, X, Y);
|
|
if FDragging then
|
|
begin
|
|
FDragging := False;
|
|
DoClick := (X >= 0) and (X < ClientWidth) and (Y >= 0) and (Y <= ClientHeight);
|
|
if FGroupIndex = 0 then
|
|
begin
|
|
{ Redraw face in-case mouse is captured }
|
|
FState := bsUp;
|
|
FMouseInControl := False;
|
|
if DoClick and not (FState in [bsExclusive, bsDown]) then
|
|
Invalidate;
|
|
end
|
|
else
|
|
if DoClick then
|
|
begin
|
|
SetDown(not FDown);
|
|
if FDown then Repaint;
|
|
end
|
|
else
|
|
begin
|
|
if FDown then FState := bsExclusive;
|
|
Repaint;
|
|
end;
|
|
if DoClick then Click;
|
|
UpdateTracking;
|
|
end;
|
|
end;
|
|
|
|
procedure TCoolButton.Click;
|
|
begin
|
|
inherited Click;
|
|
end;
|
|
|
|
function TCoolButton.GetPalette: HPALETTE;
|
|
begin
|
|
Result := Glyph.Palette;
|
|
end;
|
|
|
|
function TCoolButton.GetGlyph: TBitmap;
|
|
begin
|
|
Result := TButtonGlyph(FGlyph).Glyph;
|
|
end;
|
|
|
|
procedure TCoolButton.SetGlyph(Value: TBitmap);
|
|
begin
|
|
TButtonGlyph(FGlyph).Glyph := Value;
|
|
Invalidate;
|
|
end;
|
|
|
|
function TCoolButton.GetNumGlyphs: TNumGlyphs;
|
|
begin
|
|
Result := TButtonGlyph(FGlyph).NumGlyphs;
|
|
end;
|
|
|
|
procedure TCoolButton.SetNumGlyphs(Value: TNumGlyphs);
|
|
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 TCoolButton.GlyphChanged(Sender: TObject);
|
|
begin
|
|
Invalidate;
|
|
end;
|
|
|
|
procedure TCoolButton.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 TCoolButton.SetDown(Value: Boolean);
|
|
begin
|
|
if FGroupIndex = 0 then Value := False;
|
|
if Value <> FDown then
|
|
begin
|
|
if FDown and (not FAllowAllUp) then Exit;
|
|
FDown := Value;
|
|
if Value then
|
|
begin
|
|
if FState = bsUp then Invalidate;
|
|
FState := bsExclusive
|
|
end
|
|
else
|
|
begin
|
|
FState := bsUp;
|
|
Repaint;
|
|
end;
|
|
if Value then UpdateExclusive;
|
|
end;
|
|
end;
|
|
|
|
procedure TCoolButton.SetGroupIndex(Value: Integer);
|
|
begin
|
|
if FGroupIndex <> Value then
|
|
begin
|
|
FGroupIndex := Value;
|
|
UpdateExclusive;
|
|
end;
|
|
end;
|
|
|
|
procedure TCoolButton.SetLayout(Value: TButtonLayout);
|
|
begin
|
|
if FLayout <> Value then
|
|
begin
|
|
FLayout := Value;
|
|
Invalidate;
|
|
end;
|
|
end;
|
|
|
|
procedure TCoolButton.SetMargin(Value: Integer);
|
|
begin
|
|
if (Value <> FMargin) and (Value >= -1) then
|
|
begin
|
|
FMargin := Value;
|
|
Invalidate;
|
|
end;
|
|
end;
|
|
|
|
procedure TCoolButton.SetSpacing(Value: Integer);
|
|
begin
|
|
if Value <> FSpacing then
|
|
begin
|
|
FSpacing := Value;
|
|
Invalidate;
|
|
end;
|
|
end;
|
|
|
|
procedure TCoolButton.SetAllowAllUp(Value: Boolean);
|
|
begin
|
|
if FAllowAllUp <> Value then
|
|
begin
|
|
FAllowAllUp := Value;
|
|
UpdateExclusive;
|
|
end;
|
|
end;
|
|
|
|
procedure TCoolButton.WMLButtonDblClk(var Message: TWMLButtonDown);
|
|
begin
|
|
inherited;
|
|
if FDown then DblClick;
|
|
end;
|
|
|
|
procedure TCoolButton.CMEnabledChanged(var Message: TMessage);
|
|
const
|
|
NewState: array[Boolean] of TButtonState = (bsDisabled, bsUp);
|
|
begin
|
|
TButtonGlyph(FGlyph).CreateButtonGlyph(NewState[Enabled]);
|
|
UpdateTracking;
|
|
Repaint;
|
|
end;
|
|
|
|
procedure TCoolButton.CMButtonPressed(var Message: TMessage);
|
|
var
|
|
Sender: TCoolButton;
|
|
begin
|
|
if Message.WParam = FGroupIndex then
|
|
begin
|
|
Sender := TCoolButton(Message.LParam);
|
|
if Sender <> Self then
|
|
begin
|
|
if Sender.Down and FDown then
|
|
begin
|
|
FDown := False;
|
|
FState := bsUp;
|
|
Invalidate;
|
|
end;
|
|
FAllowAllUp := Sender.AllowAllUp;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TCoolButton.CMDialogChar(var Message: TCMDialogChar);
|
|
begin
|
|
with Message do
|
|
if IsAccel(CharCode, Caption) and Enabled then
|
|
begin
|
|
Click;
|
|
Result := 1;
|
|
end else
|
|
inherited;
|
|
end;
|
|
|
|
procedure TCoolButton.CMFontChanged(var Message: TMessage);
|
|
begin
|
|
Invalidate;
|
|
end;
|
|
|
|
procedure TCoolButton.CMTextChanged(var Message: TMessage);
|
|
begin
|
|
Invalidate;
|
|
end;
|
|
|
|
procedure TCoolButton.CMSysColorChange(var Message: TMessage);
|
|
begin
|
|
with TButtonGlyph(FGlyph) do
|
|
begin
|
|
Invalidate;
|
|
CreateButtonGlyph(FState);
|
|
end;
|
|
end;
|
|
|
|
procedure TCoolButton.WMEraseBkgnd( var message:TWMEraseBkgnd);
|
|
begin
|
|
message.Result:=0;
|
|
end;
|
|
|
|
|
|
|
|
procedure TCoolButton.CMMouseLeave(var Message: TMessage);
|
|
begin
|
|
inherited;
|
|
if FMouseInControl and Enabled and not FDragging then
|
|
begin
|
|
FMouseInControl := False;
|
|
Invalidate;
|
|
end;
|
|
end;
|
|
|
|
procedure TCoolButton.WMPaint( var message:TWMPaint);
|
|
begin
|
|
Paint;
|
|
message.Result:=0;
|
|
end;
|
|
procedure TCoolButton.WMNCPaint( var message:TWMNCPaint);
|
|
begin
|
|
Paint;
|
|
message.Result:=0;
|
|
end;
|
|
|
|
|
|
end.
|