Normalde çalışma zamanında
Button1.Font.color:=DEĞİŞTİRİLEMEZ,, ama sınıf tanımlaması yaparak buttonun arka plan rengini ve font rengini çalışma zamanında değiştirebilirsin.
uses buttons; ekle
Kod: Tümünü seç
Uses Buttons; //Ekle
//Tür Tanımlaması Aşşağıdaki gibi Olacak
{Yeni Button Sınıfının Tanımlaması}
TButton = class(StdCtrls.TButton)
private
FMouseOver, FMousePressed, FKeyboardPressed : Boolean;
FCanvas : TCanvas;
FColorEnter, FColorExit, FFontColorEnter, FFontColorExit : TColor;
procedure SetColorEnter(value : TColor);
procedure SetColorExit(value : TColor);
procedure SetFontColorEnter(value : TColor);
procedure SetFontColorExit(value : TColor);
protected
procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
procedure WndProc(var Message : TMessage); override;
procedure CMMOUSEENTER(var Message : TMessage); message CM_MOUSEENTER;
procedure CMMOUSELEAVE(var Message : TMessage); message CM_MOUSELEAVE;
procedure CMEXIT(var Message : TMessage); message CM_EXIT;
procedure WMSETFOCUS(var Message : TMessage); message WM_SETFOCUS;
procedure WMKILLFOCUS(var Message : TMessage); message WM_KILLFOCUS;
procedure WMENABLE(var Message : TWMEnable); message WM_ENABLE;
procedure DrawButton;
public
constructor Create(AOwner : TComponent); override;
destructor Destroy; override;
property ColorEnter : TColor read FColorEnter write SetColorEnter default clBtnFace;
property ColorExit : TColor read FColorExit write SetColorExit default clBtnFace;
property FontColorEnter : TColor read FFontColorEnter write SetFontColorEnter default clBtnText;
property FontColorExit : TColor read FFontColorExit write SetFontColorExit default clBtnText;
end;
TForm1 = class(TForm)
Button1: TButton;
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
Formun ONCreate Olayına:Kod: Tümünü seç
procedure TForm1.FormCreate(Sender: TObject);
begin
Button1.ColorEnter := clYellow;
Button1.ColorExit := clRed;
Button1.FontColorEnter :=clGreen;
Button1.FontColorExit := clBlue;
end;
procedure TButton.CMEXIT(var Message: TMessage);
Kod: Tümünü seç
procedure TButton.CMEXIT(var Message: TMessage);
begin
inherited;
FMousePressed := False;
FKeyboardPressed := False;
end;
procedure TButton.CMMOUSEENTER(var Message: TMessage);
Kod: Tümünü seç
procedure TButton.CMMOUSEENTER(var Message: TMessage);
begin
inherited;
if Enabled then
begin
FMouseOver := True;
Invalidate;
end;
end;
procedure TButton.CMMOUSELEAVE(var Message: TMessage);
Kod: Tümünü seç
procedure TButton.CMMOUSELEAVE(var Message: TMessage);
begin
inherited;
if Enabled then
begin
FMouseOver := False;
Invalidate;
end;
end;
constructor TButton.Create(AOwner: TComponent);
Kod: Tümünü seç
constructor TButton.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FCanvas := TCanvas.Create;
FCanvas.Handle := GetWindowDC(Handle);
FColorEnter := clBtnFace;
FColorExit := clBtnFace;
FFontColorEnter := clBtnText;
FFontColorExit := clBtnText;
FMouseOver := False;
FMousePressed := False;
FKeyboardPressed := False;
end;
destructor TButton.Destroy;
Kod: Tümünü seç
destructor TButton.Destroy;
begin
FCanvas.Free;
inherited Destroy;
end;
procedure TButton.DrawButton;
Kod: Tümünü seç
procedure TButton.DrawButton;
var
RC : TRect;
begin
with FCanvas do
begin
RC := ClientRect;
InflateRect(rc,-2,-2);
Font.Assign(Self.Font);
if FMouseOver then
begin
Color := FColorEnter;
Font.Color := FFontColorEnter;
end
else
begin
Color := FColorExit;
Font.Color := FFontColorExit;
end;
Brush.Color := Color;
if not Enabled then
Brush.Color := FColorExit;
if Self = TCustomForm(Parent).ActiveControl then
begin
if not ((FMousePressed and FMouseOver) or (FKeyboardPressed and not FMousePressed)) then
InflateRect(RC,-1,-1);
FillRect(RC);
if Caption <> '' then
if Focused then
DrawFocusRect(Rect(4,4,Width - 4, Height - 4));
end
else
begin
if Default then
if not (TCustomForm(Parent).ActiveControl is TButtonControl) then
InflateRect(RC, -1, -1);
FillRect(RC);
end;
RC := ClientRect;
if (FMousePressed and FMouseOver) or (FKeyboardPressed and not FMousePressed) then
OffSetRect(RC, 1, 1);
SetBkMode(Handle, TRANSPARENT);
if Enabled then
DrawText(Handle,PChar(Caption), Length(PChar(Caption)),RC,DT_SINGLELINE or DT_VCENTER or DT_CENTER or DT_NOCLIP)
else
begin
OffSetRect(RC,1,1);
Font.Color := clCaptionText;
DrawText(Handle,PChar(Caption), Length(PChar(Caption)),RC,DT_SINGLELINE or DT_VCENTER or DT_CENTER or DT_NOCLIP);
OffSetRect(RC,-1,-1);
Font.Color := clInactiveCaption;
DrawText(Handle,PChar(Caption), Length(PChar(Caption)),RC,DT_SINGLELINE or DT_VCENTER or DT_CENTER or DT_NOCLIP)
end;
end;
end;
procedure TButton.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
Kod: Tümünü seç
procedure TButton.MouseDown(Button: TMouseButton; Shift: TShiftState; X,
Y: Integer);
begin
inherited MouseDown(Button, Shift, X,Y);
if Button = mbLeft then
FMousePressed := True;
end;
procedure TButton.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
Kod: Tümünü seç
procedure TButton.MouseUp(Button: TMouseButton; Shift: TShiftState; X,
Y: Integer);
begin
inherited MouseUp(Button, Shift, X,Y);
if Button = mbLeft then
begin
if FKeyboardPressed then
begin
Perform(WM_KEYDOWN,VK_SPACE,0);
FKeyboardPressed := False;
end;
FMousePressed := False;
end;
end;
procedure TButton.SetColorEnter(value: TColor);
Kod: Tümünü seç
procedure TButton.SetColorEnter(value: TColor);
begin
if Value <> FColorEnter then
begin
FColorEnter := Value;
Invalidate;
end;
end;
procedure TButton.SetColorExit(value: TColor);
Kod: Tümünü seç
procedure TButton.SetColorExit(value: TColor);
begin
if Value <> FColorExit then
begin
FColorExit := Value;
Invalidate;
end;
end;
procedure TButton.SetFontColorEnter(value: TColor);
Kod: Tümünü seç
procedure TButton.SetFontColorEnter(value: TColor);
begin
if Value <> FColorEnter then
begin
FFontColorEnter := Value;
Invalidate;
end;
end;
procedure TButton.SetFontColorExit(value: TColor);
Kod: Tümünü seç
procedure TButton.SetFontColorExit(value: TColor);
begin
if Value <> FColorExit then
begin
FFontColorExit := Value;
Invalidate;
end;
end;
procedure TButton.WMENABLE(var Message: TWMEnable);
Kod: Tümünü seç
procedure TButton.WMENABLE(var Message: TWMEnable);
begin
inherited;
Invalidate;
end;
procedure TButton.WMKILLFOCUS(var Message: TMessage);
Kod: Tümünü seç
procedure TButton.WMKILLFOCUS(var Message: TMessage);
var
CursorPos : TPoint;
begin
inherited;
GetCursorPos(CursorPos);
CursorPos := ScreenToClient(CursorPos);
if ((CursorPos.X > 0) and (CursorPos.X < Width)) and
((CursorPos.Y > 0) and (CursorPos.Y < Height)) then
Perform(CM_MOUSEENTER,0,0)
else
Perform(CM_MOUSELEAVE,0,0);
end;
procedure TButton.WMSETFOCUS(var Message: TMessage);
Kod: Tümünü seç
procedure TButton.WMSETFOCUS(var Message: TMessage);
var
CursorPos : TPoint;
begin
inherited;
GetCursorPos(CursorPos);
CursorPos := ScreenToClient(CursorPos);
if ((CursorPos.X > 0) and (CursorPos.X < Width)) and
((CursorPos.Y > 0) and (CursorPos.Y < Height)) then
Perform(CM_MOUSEENTER,0,0)
else
Perform(CM_MOUSELEAVE,0,0);
end;
procedure TButton.WndProc(var Message: TMessage);
Kod: Tümünü seç
procedure TButton.WndProc(var Message: TMessage);
begin
inherited;
with Message do
begin
case Msg of
WM_SHOWWINDOW, WM_PAINT, WM_LBUTTONDOWN, WM_LBUTTONUP, WM_LBUTTONDBLCLK,
WM_KILLFOCUS , WM_SETFOCUS :
begin
if Msg = WM_KILLFOCUS then
begin
FMousePressed := False;
FKeyboardPressed := False;
end;
DrawButton;
end;
WM_KEYUP :
if TWMKeyUp(Message).CharCode = VK_SPACE then
begin
FKeyboardPressed := False;
DrawButton;
end;
WM_KEYDOWN :
begin
if (TWMKeyDown(Message).CharCode = VK_SPACE) and not (FKeyboardPressed) then
begin
FKeyboardPressed := True;
DrawButton;
end
else
if TWMKeyDown(Message).CharCode <> VK_SPACE then
begin
FKeyboardPressed := False;
DrawButton;
end;
end;
end;
end;
end;
end.
Yukarıdaki kod çalışma zamanında imleç buttonun üzerine gelince buttonun arkaplan rengini ve font rengini değiştirir.
Eğer ikon animasyonu kullanmak istersen:
global olarak tanımla:
bir imagelist ekle ve bir timer ekle. timerin OnTimer olayına:
Kod: Tümünü seç
procedure TForm1.Timer1Timer(Sender: TObject);
begin
ImageList1.GetIcon(IconIndex,Icon);
Inc(IconIndex);
if IconIndex = ImageList1.Count then
IconIndex := 0;
end;