Hello Jason,

I love to share my TDBColorSpeedButton component.

Fed up with them Gray Button? This one is base on TSpeedButton,
but with added features.

Button Up, Down and Disabled colors,
Glymps
Follows a DB
User defined Caption when DB is closed, thus it
can be used without a DB
etc ....

Great to build a dynamically a menu of buttons, based on elements
of a DB or just a list.

Works great with TIBO, but it should be simple to adapt to TIB_, but
I need some guidelines for the TDataLink equiv component.

Best Regards,
Hans.

----------

unit DBColorSpeedButton;

{$S-,W-,R-}
{$C PRELOAD}

interface

uses Windows, Messages, Classes, Controls, Forms, Graphics, StdCtrls,
ExtCtrls, CommCtrl, Buttons, DB;

type
TFieldDataLink = class(TDataLink)
private
FField: TField;
FFieldName: string;
FControl: TComponent;
FEditing: Boolean;
FModified: Boolean;
FOnDataChange: TNotifyEvent;
FOnEditingChange: TNotifyEvent;
FOnUpdateData: TNotifyEvent;
FOnActiveChange: TNotifyEvent;
procedure SetField(Value: TField);
procedure SetFieldName(const Value: string);
procedure UpdateField;
protected
procedure ActiveChanged; override;
procedure LayoutChanged; override;
procedure RecordChanged(Field: TField); override;
procedure UpdateData; override;
public
constructor Create;
procedure Reset;
property Control: TComponent read FControl write FControl;
property Editing: Boolean read FEditing;
property Field: TField read FField;
property FieldName: string read FFieldName write SetFieldName;
property OnDataChange: TNotifyEvent read FOnDataChange write FOnDataChange;
property OnEditingChange: TNotifyEvent read FOnEditingChange write FOnEditingChange;
property OnUpdateData: TNotifyEvent read FOnUpdateData write FOnUpdateData;
property OnActiveChange: TNotifyEvent read FOnActiveChange write FOnActiveChange;
end;


type
TButtonLayout = (blGlyphLeft, blGlyphRight, blGlyphTop, blGlyphBottom);
TButtonState = (bsUp, bsDisabled, bsDown, bsExclusive);
TButtonStyle = (bsAutoDetect, bsNew);
TNumGlyphs = 1..4;

TDBColorSpeedButton = class(TGraphicControl)

private
FGroupIndex: Integer;
FGlyph: Pointer;
FDown: Boolean;
FAlignment : TAlignment;
FDragging: Boolean;
FAllowAllUp: Boolean;
FLayout: TButtonLayout;
FSpacing: Integer;
FMargin: Integer;
FColor : TColor;
FDownColor : TColor;
FClosedCaption : String;
FDisabledColor : TColor;
FMouseInControl: Boolean;
FDataLink: TFieldDataLink;
procedure DataChange(Sender: TObject);
function GetDataField: string;
function GetDataSource: TDataSource;
function GetField: TField;
function GetFieldText: string;
procedure SetDataField(const Value: string);
procedure SetDataSource(Value: TDataSource);

procedure CMGetDataLink(var Message: TMessage); message CM_GETDATALINK;
protected

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 SetColor(Value: TColor);
procedure SetAlignment(Value: TAlignment);
procedure SetDownColor(Value: TColor);
procedure SetClosedCaption(Value: String);
procedure SetDisabledColor(Value: TColor);
procedure SetAllowAllUp(Value: Boolean);
procedure SetGroupIndex(Value: Integer);
procedure SetLayout(Value: TButtonLayout);
procedure SetSpacing(Value: Integer);
procedure SetMargin(Value: Integer);
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 CMMouseEnter(var Message: TMessage); message CM_MOUSEENTER;
procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE;

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;
//
property Field: TField read GetField;
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 DownColor: TColor read FDownColor write SetDownColor default clBtnFace;
property ClosedCaption: string read FClosedCaption write SetClosedCaption; // default Name;
property DisabledColor: TColor read FDisabledColor write SetDisabledColor default clBtnFace;
property Caption;
property Align;
property Enabled;
property Color: TColor read FColor write SetColor default clBtnFace;
property Alignment: TAlignment read FAlignment write SetAlignment
default taCenter; //LeftJustify;

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 1;
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;
property OnStartDrag;
property OnDragDrop;
property OnDragOver;
property OnEndDrag;

property DataField: string read GetDataField write SetDataField;
property DataSource: TDataSource read GetDataSource write SetDataSource;
end;

TBitBtnKind = (bkCustom, bkOK, bkCancel, bkHelp, bkYes, bkNo, bkClose,
bkAbort, bkRetry, bkIgnore, bkAll);

procedure Register;

implementation

uses Consts;

//{$R BUTTONS.RES}

{ TColorBitBtn data }
{
var
BitBtnResNames: array[TBitBtnKind] of PChar = (
nil, 'BBOK', 'BBCANCEL', 'BBHELP', 'BBYES', 'BBNO', 'BBCLOSE',
'BBABORT', 'BBRETRY', 'BBIGNORE', 'BBALL');
BitBtnCaptions: array[TBitBtnKind] of Pointer = (
nil,nil,nil,nil,nil,nil,nil,nil,nil,nil,nil);

BitBtnModalResults: array[TBitBtnKind] of TModalResult = (
0, mrOk, mrCancel, 0, mrYes, mrNo, 0, mrAbort, mrRetry, mrIgnore,
mrAll);

var
ColorBitBtnGlyphs: array[TBitBtnKind] of TBitmap;


function GetColorBitBtnGlyph(Kind: TBitBtnKind): TBitmap;
begin
if ColorBitBtnGlyphs[Kind] = nil then
begin
ColorBitBtnGlyphs[Kind] := TBitmap.Create;
ColorBitBtnGlyphs[Kind].LoadFromResourceName(HInstance, BitBtnResNames[Kind]);
end;
Result := ColorBitBtnGlyphs[Kind];
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;

TColorButtonGlyph = 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;
Alignment: TALignment);
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; Alignment: TAlignment{; 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;


{ TColorButtonGlyph }

constructor TColorButtonGlyph.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 TColorButtonGlyph.Destroy;
begin
FOriginal.Free;
Invalidate;
if Assigned(GlyphCache) and GlyphCache.Empty then
begin
GlyphCache.Free;
GlyphCache := nil;
end;
inherited Destroy;
end;

procedure TColorButtonGlyph.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 TColorButtonGlyph.GlyphChanged(Sender: TObject);
begin
if Sender = FOriginal then
begin
FTransparentColor := FOriginal.TransparentColor;
Invalidate;
if Assigned(FOnChange) then FOnChange(Self);
end;
end;

procedure TColorButtonGlyph.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 TColorButtonGlyph.SetNumGlyphs(Value: TNumGlyphs);
begin
if (Value <> FNumGlyphs) and (Value > 0) then
begin
Invalidate;
FNumGlyphs := Value;
GlyphChanged(Glyph);
end;
end;

function TColorButtonGlyph.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 TColorButtonGlyph.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,
ColorToRGB(clBtnFace), clNone, ILD_Transparent {ILD_Normal});
end;

procedure TColorButtonGlyph.DrawButtonText(Canvas: TCanvas; const Caption: string;
TextBounds: TRect; State: TButtonState);
begin
with Canvas do
begin
Brush.Style := bsClear;

DrawText(Handle, PChar(Caption), Length(Caption), TextBounds,
DT_CENTER or DT_VCENTER {or DT_SINGLELINE} or DT_WordBreak or DT_NoClip);

end;
end;

procedure TColorButtonGlyph.CalcButtonLayout(Canvas: TCanvas; const Client: TRect;
const Offset: TPoint; const Caption: string; Layout: TButtonLayout; Margin,
Spacing: Integer; var GlyphPos: TPoint; var TextBounds: TRect; Alignment: TALignment);
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
if Layout <> blGlyphLeft then // hans
TextBounds := Rect(0, 0, Client.Right - Client.Left , 0)
else
TextBounds := Rect(0, 0, Client.Right - Client.Left - GlyphSize.x, 0);

DrawText(Canvas.Handle, PChar(Caption), Length(Caption), TextBounds, DT_CALCRECT + DT_WORDBREAK);
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 //hans
if GlyphSize.X > 0 then
// Margin := 1;
Margin := 0;

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 }
if GlyphSize.X > 0 then //Hans

with GlyphPos do
begin
Inc(X, Client.Left + Offset.X);
Inc(Y, Client.Top + Offset.Y);
end;

if Alignment = taCenter then // little less
OffsetRect(TextBounds, TextPos.X + Client.Left + Offset.X { -1},
TextPos.Y + Client.Top + Offset.X)
else
if Alignment = taLeftJustify then
begin
OffsetRect(TextBounds, Client.Left + Offset.X + GlyphPos.X + GlyphSize.X,
TextPos.Y + Client.Top + Offset.X);
end
else
OffsetRect(TextBounds, Client.Right-TextBounds.Right-TextBounds.Left -3 + Offset.X ,
TextPos.Y + Client.Top + Offset.X);

end;

function TColorButtonGlyph.Draw(Canvas: TCanvas; const Client: TRect;
const Offset: TPoint; const Caption: string; Layout: TButtonLayout;
Margin, Spacing: Integer; State: TButtonState; Alignment: TAlignment{; Transparent: Boolean}): TRect;
var
GlyphPos: TPoint;
begin
CalcButtonLayout(Canvas, Client, Offset, Caption, Layout, Margin, Spacing,
GlyphPos, Result, Alignment);
DrawButtonGlyph(Canvas, GlyphPos, State{, Transparent});
DrawButtonText(Canvas, Caption, Result, State);
end;

{ TDBColorSpeedButton }

constructor TDBColorSpeedButton.Create(AOwner: TComponent);
begin
FGlyph := TColorButtonGlyph.Create;
TColorButtonGlyph(FGlyph).OnChange := GlyphChanged;
inherited Create(AOwner);
SetBounds(0, 0, 25, 25);
ControlStyle := [csCaptureMouse, csOpaque, csDoubleClicks];
ParentFont := True;
FSpacing := 4;
FMargin := -1;
FLayout := blGlyphLeft;
Inc(ButtonCount);

FDataLink := TFieldDataLink.Create;
FDataLink.Control := Self;
FDataLink.OnDataChange := DataChange;
end;

destructor TDBColorSpeedButton.Destroy;
begin
Dec(ButtonCount);
if ButtonCount = 0 then
begin
Pattern.Free;
Pattern := nil;
end;

FDataLink.Free;
FDataLink := nil;

inherited Destroy;
TColorButtonGlyph(FGlyph).Free;
end;

procedure TDBColorSpeedButton.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
if not Enabled then
begin
FState := bsDisabled;
FDragging := False;
end
else
if FState = bsDisabled then
if FDown and (GroupIndex <> 0) then
FState := bsExclusive
else
FState := bsUp;

Canvas.Font := Self.Font;
PaintRect := Rect(0, 0, Width, Height);

//if not FFlat then
begin
DrawFlags := DFCS_BUTTONPUSH or DFCS_ADJUSTRECT;

if FState in [bsDown, bsExclusive] then
DrawFlags := DrawFlags or DFCS_PUSHED;

// Frame or No Frame
DrawFrameControl(Canvas.Handle, PaintRect, DFC_BUTTON, DrawFlags);
end;

if FState in [bsDown, bsExclusive] then
begin
if (FState = bsExclusive) and ({not FFlat or }not FMouseInControl) then
begin
if Pattern = nil then
CreateBrushPattern;

Canvas.Brush.Bitmap := Pattern;
Canvas.FillRect(PaintRect);
end;

Offset.X := 1;
Offset.Y := 1;
end
else
begin
Offset.X := 0;
Offset.Y := 0;
end;

//hans
if FState in [bsUp] then
Canvas.Brush.color := Color
else
if FState in [bsDisabled] then
Canvas.Brush.Color := DisabledColor
else
Canvas.Brush.Color := DownColor;

Canvas.FillRect(PaintRect);

TColorButtonGlyph(FGlyph).Draw(Canvas, PaintRect, Offset, GetFieldText{Caption}, FLayout, FMargin,
FSpacing, FState, FAlignment{, FFlat});

end;

procedure TDBColorSpeedButton.Loaded;
var
State: TButtonState;
begin
inherited Loaded;
if Enabled then
State := bsUp
else
State := bsDisabled;
TColorButtonGlyph(FGlyph).CreateButtonGlyph(State);
end;

procedure TDBColorSpeedButton.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 TDBColorSpeedButton.MouseMove(Shift: TShiftState; X, Y: Integer);
var
NewState: TButtonState;
begin
inherited MouseMove(Shift, X, Y);

if FDragging then
begin
if not FDown then NewState := bsUp
else NewState := bsExclusive;
if (X >= 0) and (X < ClientWidth) and (Y >= 0) and (Y <= ClientHeight) then
if FDown then NewState := bsExclusive else NewState := bsDown;
if NewState <> FState then
begin
FState := NewState;
Invalidate;
end;
end;

end;

procedure TDBColorSpeedButton.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 TDBColorSpeedButton.Click;
begin
inherited Click;
end;

function TDBColorSpeedButton.GetPalette: HPALETTE;
begin
Result := Glyph.Palette;
end;

function TDBColorSpeedButton.GetGlyph: TBitmap;
begin
Result := TColorButtonGlyph(FGlyph).Glyph;
end;

procedure TDBColorSpeedButton.SetGlyph(Value: TBitmap);
begin
TColorButtonGlyph(FGlyph).Glyph := Value;
Invalidate;
end;

function TDBColorSpeedButton.GetNumGlyphs: TNumGlyphs;
begin
Result := TColorButtonGlyph(FGlyph).NumGlyphs;
end;

procedure TDBColorSpeedButton.SetNumGlyphs(Value: TNumGlyphs);
begin
if Value < 0 then Value := 1
else if Value > 4 then Value := 4;
if Value <> TColorButtonGlyph(FGlyph).NumGlyphs then
begin
TColorButtonGlyph(FGlyph).NumGlyphs := Value;
Invalidate;
end;
end;

procedure TDBColorSpeedButton.GlyphChanged(Sender: TObject);
begin
Invalidate;
end;

procedure TDBColorSpeedButton.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 TDBColorSpeedButton.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;

function TDBColorSpeedButton.GetDataSource: TDataSource;
begin
Result := FDataLink.DataSource;
end;

procedure TDBColorSpeedButton.SetDataSource(Value: TDataSource);
begin
if not (FDataLink.DataSourceFixed and (csLoading in ComponentState)) then
FDataLink.DataSource := Value;
if Value <> nil then Value.FreeNotification(Self);
end;

function TDBColorSpeedButton.GetDataField: string;
begin
Result := FDataLink.FieldName;
end;

procedure TDBColorSpeedButton.SetDataField(const Value: string);
begin
FDataLink.FieldName := Value;
end;

function TDBColorSpeedButton.GetField: TField;
begin
Result := FDataLink.Field;
end;

function TDBColorSpeedButton.GetFieldText: string;
begin
if FDataLink.Field <> nil then
Result := FDataLink.Field.DisplayText
else
if csDesigning in ComponentState then Result := ClosedCaption {Name }
else
Result := ClosedCaption ; {''};
end;

procedure TDBColorSpeedButton.DataChange(Sender: TObject);
begin
Caption := GetFieldText;
end;

procedure TDBColorSpeedButton.CMGetDataLink(var Message: TMessage);
begin
Message.Result := Integer(FDataLink);
end;

procedure TFieldDataLink.SetField(Value: TField);
begin
if FField <> Value then
begin
FField := Value;
EditingChanged;
RecordChanged(nil);
end;
end;

procedure TDBColorSpeedButton.SetColor(Value: TColor);
begin
if Value <> FColor then
begin
FColor := Value;
Invalidate;
end;
end;

procedure TDBColorSpeedButton.SetDownColor(Value: TColor);
begin
if Value <> FDownColor then
begin
FDownColor := Value;
Invalidate;
end;
end;

procedure TDBColorSpeedButton.SetClosedCaption(Value: string);
begin
if Value <> FClosedCaption then
begin
FClosedCaption := Value;
Invalidate;
end;
end;

procedure TDBColorSpeedButton.SetDisabledColor(Value: TColor);
begin
if Value <> FDisabledColor then
begin
FDisabledColor := Value;
Invalidate;
end;
end;


procedure TDBColorSpeedButton.SetAlignment(Value: TAlignment);
begin
if FAlignment <> Value then
begin
FAlignment := Value;
Invalidate;
end;
end;

procedure TDBColorSpeedButton.SetGroupIndex(Value: Integer);
begin
if FGroupIndex <> Value then
begin
FGroupIndex := Value;
UpdateExclusive;
end;
end;

procedure TDBColorSpeedButton.SetLayout(Value: TButtonLayout);
begin
if FLayout <> Value then
begin
FLayout := Value;
Invalidate;
end;
end;

procedure TDBColorSpeedButton.SetMargin(Value: Integer);
begin
if (Value <> FMargin) and (Value >= -1) then
begin
FMargin := Value;
Invalidate;
end;
end;

procedure TDBColorSpeedButton.SetSpacing(Value: Integer);
begin
if Value <> FSpacing then
begin
FSpacing := Value;
Invalidate;
end;
end;

procedure TDBColorSpeedButton.SetAllowAllUp(Value: Boolean);
begin
if FAllowAllUp <> Value then
begin
FAllowAllUp := Value;
UpdateExclusive;
end;
end;

// Hans , prevent funny onDoubleClick behavior
procedure TDBColorSpeedButton.WMLButtonDblClk(var Message: TWMLButtonDown);
begin
// inherited;
// if FDown then DblClick;
end;

procedure TDBColorSpeedButton.CMEnabledChanged(var Message: TMessage);
const
NewState: array[Boolean] of TButtonState = (bsDisabled, bsUp);
begin
TColorButtonGlyph(FGlyph).CreateButtonGlyph(NewState[Enabled]);
Repaint;
end;

procedure TDBColorSpeedButton.CMButtonPressed(var Message: TMessage);
var
Sender: TDBColorSpeedButton;
begin
if Message.WParam = FGroupIndex then
begin
Sender := TDBColorSpeedButton(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 TDBColorSpeedButton.CMDialogChar(var Message: TCMDialogChar);
begin
with Message do
if IsAccel(CharCode, Caption) and Enabled then
begin
Click;
Result := 1;
end else
inherited;
end;

procedure TDBColorSpeedButton.CMFontChanged(var Message: TMessage);
begin
Invalidate;
end;

procedure TDBColorSpeedButton.CMTextChanged(var Message: TMessage);
begin
Invalidate;
end;

procedure TDBColorSpeedButton.CMMouseEnter(var Message: TMessage);
begin
inherited;

end;

procedure TDBColorSpeedButton.CMMouseLeave(var Message: TMessage);
begin
inherited;

end;

{ TFieldDataLink }

constructor TFieldDataLink.Create;
begin
inherited Create;
VisualControl := True;
end;

procedure TFieldDataLink.SetFieldName(const Value: string);
begin
if FFieldName <> Value then
begin
FFieldName := Value;
UpdateField;
end;
end;

procedure TFieldDataLink.UpdateField;
begin
if Active and (FFieldName <> '') then
begin
FField := nil;
if Assigned(FControl) then
SetField(GetFieldProperty(DataSource.DataSet, FControl, FFieldName)) else
SetField(DataSource.DataSet.FieldByName(FFieldName));
end else
SetField(nil);
end;

procedure TFieldDataLink.Reset;
begin
RecordChanged(nil);
end;

procedure TFieldDataLink.ActiveChanged;
begin
UpdateField;
if Assigned(FOnActiveChange) then FOnActiveChange(Self);
end;

procedure TFieldDataLink.RecordChanged(Field: TField);
begin
if (Field = nil) or (Field = FField) then
begin
if Assigned(FOnDataChange) then FOnDataChange(Self);
FModified := False;
end;
end;

procedure TFieldDataLink.LayoutChanged;
begin
UpdateField;
end;

procedure TFieldDataLink.UpdateData;
begin
if FModified then
begin
if (Field <> nil) and Assigned(FOnUpdateData) then FOnUpdateData(Self);
FModified := False;
end;
end;

procedure Register;
begin
RegisterComponents('HPSutils', [TDBColorSpeedButton]);
end;

end.



[Non-text portions of this message have been removed]