Delphi Peak

Delphi’nin kendi VCL’inde bulunan button sınıflarında Icon yüklenememesine hep kızmışımdır ama garip garip bitmap dosyaları ile hep idare etmiş ve aman sonra yazarım demiştim.Eh geçenlerde bir arkadaşımın da teşvikiyle oturdum yazdım.Sizlerle paylaşayım istedim. Buyrun; kodda anlaşılmayan sormak istediğiniz birşeyler olursa yardımcı olmaya çalışırım.

{
Icon Speed Button

11/05/2006

Author : Tuğrul HELVACI
Mail   : king_of_delphi@hotmail.com

You can load any icon file and you can use background bitmap.

Herhangi bir icon dosyası yükleyebilir, arka zemin için bir bitmap dosyası yükleyebilir,
başlık ve icon için X,Y koordinatlarını verebilirsiniz.
}
unit IconSpeedButton;

interface

uses
Windows, SysUtils, Classes, Controls, Buttons, Messages, Types, Graphics, StdCtrls;

type
TPaintType = (ptColor, ptBitmap);

TIconSpeedButton = class(TSpeedButton)
private
fControlCanvas : TControlCanvas;
fIcon,
fDisabledIcon  : TIcon;

fIconX,
fIconY,
fTextX,
fTextY         : Integer;
fColor         : TColor;
fPaintType     : TPaintType;
fBitmap        : TBitmap;
fImageList     : TImageList;

procedure SetIcon(const Value : TIcon);
procedure SetColor(const Value : TColor);

function GetIntegerValues(const AIndex : Integer)  :Integer;
procedure SetIntegerValues(const AIndex : Integer; const Value : Integer);

procedure SetPaintType(const Value : TPaintType);
procedure SetBitmap(const Value : TBitmap);

procedure ConvertGrayScale;
protected
property Canvas : TControlCanvas read fControlCanvas;
public
constructor Create(AOwner : TComponent); override;
destructor Destroy; override;
procedure WMPaint(var Message : TWMPaint); message WM_PAINT;
procedure CMMouseEnter(var Message: TMessage); message CM_MOUSEENTER;
procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE;
published
property IconX      : Integer index 0 read GetIntegerValues write SetIntegerValues;
property IconY      : Integer index 1 read GetIntegerValues write SetIntegerValues;
property TextX      : Integer index 2 read GetIntegerValues write SetIntegerValues;
property TextY      : Integer index 3 read GetIntegerValues write SetIntegerValues;

property Icon       : TIcon read fIcon write SetIcon;
property Color      : TColor read fColor write SetColor;
property PaintType  : TPaintType read fPaintType write SetPaintType;
property Bitmap     : TBitmap read fBitmap write SetBitmap;
end;

procedure Register;

implementation

procedure Register;
begin
RegisterComponents('Tugrul', [TIconSpeedButton]);
end;

{ TIconSpeedButton }

procedure TIconSpeedButton.CMMouseEnter(var Message: TMessage);
var
rRect : TRect;
begin
inherited;
Canvas.Brush.Color := clBtnShadow;
rRect       := ClientRect;

rRect.Left    := rRect.Left   + 1;
rRect.Top     := rRect.Top    + 1;
rRect.Right   := rRect.Right  - 1;
rRect.Bottom  := rRect.Bottom - 1;

Canvas.FrameRect(rRect);

Canvas.Brush.Style := bsClear;
Canvas.Font.Style := Canvas.Font.Style + [fsUnderline];
Canvas.TextOut(
TextX,
TextY,
Caption
);
end;

procedure TIconSpeedButton.CMMouseLeave(var Message: TMessage);
begin
inherited;
Invalidate;
end;

procedure TIconSpeedButton.ConvertGrayScale;
var
IconInfo : _ICONINFO;
bmp      : TBitmap;

iX,
iY,
iOrt     : Integer;
clr      : TColor;
begin
GetIconInfo(fDisabledIcon.Handle, IconInfo);

bmp := TBitmap.Create;
try
bmp.Width := fDisabledIcon.Width;
bmp.Height:= fDisabledIcon.Height;
bmp.Handle:= IconInfo.hbmColor;

for iX := 0 to bmp.Width - 1 do
for iY := 0 to bmp.Height - 1 do
begin
clr := bmp.Canvas.Pixels[iX, iY];
iOrt := (
GetRValue(clr) +
GetGValue(clr) +
GetBValue(clr)
) div 3;

bmp.Canvas.Pixels[iX, iY] := RGB(iOrt, iOrt, iOrt);
end;

IconInfo.hbmColor := bmp.Handle;
//fDisabledIcon.ReleaseHandle;
fDisabledIcon.Handle := CreateIconIndirect(IconInfo);

fImageList.AddIcon(fDisabledIcon);
fImageList.GetIcon(0, fDisabledIcon);
fImageList.Delete(0);
finally
FreeAndNil(bmp);
end;
end;

constructor TIconSpeedButton.Create(AOwner: TComponent);
begin
inherited;
fControlCanvas := TControlCanvas.Create;
fControlCanvas.Control := Self;

fIcon := TIcon.Create;
fDisabledIcon := TIcon.Create;

fImageList := TImageList.Create(Self);
fImageList.Width := 32;
fImageList.Height := 32;

fIconX := 1;
fIconY := 1;
fTextX := 10;
fTextY := 10;
fColor := clWhite;
fPaintType := ptColor;
fBitmap := TBitmap.Create;
fBitmap.Width := 100;
fBitmap.Height := 100;
end;

destructor TIconSpeedButton.Destroy;
begin
if Assigned(fControlCanvas) then fControlCanvas.Free;
if Assigned(fIcon) then fIcon.Free;
if Assigned(fDisabledIcon) then fDisabledIcon.Free;
if Assigned(fImageList) then fImageList.Free;
inherited;
end;

function TIconSpeedButton.GetIntegerValues(const AIndex: Integer): Integer;
begin
case AIndex of
0 : Result := fIconX;
1 : Result := fIconY;
2 : Result := fTextX;
3 : Result := fTextY;
end;
end;

procedure TIconSpeedButton.SetBitmap(const Value: TBitmap);
begin
fBitmap.Assign(Value);
Invalidate;
end;

procedure TIconSpeedButton.SetColor(const Value: TColor);
var
mRect : TRect;
begin
fColor := Value;

mRect := ClientRect;
mRect.Left    := mRect.Left   + 1;
mRect.Top     := mRect.Top    + 1;
mRect.Right   := mRect.Right  - 1;
mRect.Bottom  := mRect.Bottom - 1;

case PaintType of
ptColor : fControlCanvas.Brush.Color := fColor;
ptBitmap: if Bitmap  nil then fControlCanvas.Brush.Bitmap := Bitmap;
end;
fControlCanvas.FillRect(mRect);

if Assigned(Icon) then
fControlCanvas.Draw(IconX,IconY,fIcon);

fControlCanvas.Brush.Style := bsClear;
fControlCanvas.Font := Font;
fControlCanvas.TextOut(
TextX,
TextY,
Caption
);
end;

procedure TIconSpeedButton.SetIcon(const Value: TIcon);
begin
fIcon.Assign(Value);
Invalidate;
end;

procedure TIconSpeedButton.SetIntegerValues(const AIndex, Value: Integer);
begin
case AIndex of
0 : fIconX := Value;
1 : fIconY := Value;
2 : fTextX := Value;
3 : fTextY := Value;
end;
Invalidate;
end;

procedure TIconSpeedButton.SetPaintType(const Value: TPaintType);
begin
fPaintType := Value;
Invalidate;
end;

procedure TIconSpeedButton.WMPaint(var Message: TWMPaint);
var
mRect : TRect;
mRgn  : HRGN;
mColor: TColor;
begin
inherited;
try
mRect := ClientRect;
mRect.Left    := mRect.Left   + 1;
mRect.Top     := mRect.Top    + 1;
mRect.Right   := mRect.Right  - 1;
mRect.Bottom  := mRect.Bottom - 1;

case PaintType of
ptColor : fControlCanvas.Brush.Color := Color;
ptBitmap: if Bitmap  nil then fControlCanvas.Brush.Bitmap := Bitmap;
end;

fControlCanvas.FillRect(mRect);

fDisabledIcon.Assign(fIcon);
ConvertGrayScale;

if Assigned(Icon) then
if Enabled
then fControlCanvas.Draw(IconX,IconY,fIcon)
else fControlCanvas.Draw(IconX,IconY,fDisabledIcon);

fControlCanvas.Font := Font;
mColor := Font.Color;

fControlCanvas.Brush.Style := bsClear;
if not Enabled
then fControlCanvas.Font.Color := clGray
else fControlCanvas.Font.Color := mColor;

fControlCanvas.TextOut(
TextX,
TextY,
Caption
);
except
end;
end;

end.

This entry was posted on Monday, May 22nd, 2006 at 10:49:39 and is filed under bileşenler, delphi. You can follow any responses to this entry through the RSS 2.0 feed. You can leave a response, or trackback from your own site.