Kol-ce runtime farklı tuş oluşturma.

Kol-ce runtime yeni bileşenler oluştururken Delphi tarzı kod kullanabiliriz.
Bu Delphi ile yapılan bileşenlerin kolayca Kol-ce ortamına taşımayı kolaylaştıracaktır.

menutus

Örneğin yeni button yapalım.
Burada TObject den türetilmiş bir sınıf ile başlayalım.

constructor (sınıf yapılandırılması) da
Button := NewButton(AOwner, UTF8Decode(‘MenüTuş’));
satırı ile yeni buttun oluşturuyoruz.
button.Style := button.Style + BS_OWNERDRAW;
bu satırda ise oluşturduğumuz button stiline çizim bizim tarfından yapılacağını söylüyoruz.

Daha sonra olayları (event) tanımlara göre atama yapıyoruz.
BMouseDown(Sender: PControl; var Mouse: TMouseEventData);
Button.OnMouseDown := BMouseDown;
Button.OnMouseUp := BMouseUp;
Button.OnPaint := ButtonPaint;
Button.OnMouseEnter := ButtonMouseEnter;
Button.OnMouseLeave := ButtonMouseleave;
Button.OnMouseDblClk := ButtonMouseDblClk;

gibi.
Button.Show;
ile oluşturduğumuz ve ataması yapılılan olayları ile button oluşturuyoruz.

Oluşturduğumuz button’ a dışardan onclick olayına atama yapmak için.

procedure TForm1.MenuTus1Bas(sender: pobj);
begin
ShowMessage(PControl(sender).Caption);
end;

bir procedure oluşturup.
Geriye dönen button.OnClick:=MenuTus1Bas;
şeklinde atama yapıyoruz.

Bileşenin kodu:
[code lang=”Delphi”]

unit MenuTus2;

interface

uses
Windows, KOL;

type
TDurum = (dNormal, dUzerinde, dBasildi);

type

{ TMenuTus2 }

TMenuTus2 = class(TObject)
private
Button: PControl;
FBlend: extended;
Fdurum: TDurum;
FCerceveRenk: Tcolor;
Fmouse: boolean;
function ColorBetween(C1, C2: TColor; blend: extended): TColor;
procedure SetBlend(const AValue: extended);
procedure SetCerceveRenk(const Value: Tcolor);
{ Private declarations }
protected

procedure ButtonPaint(Sender: PControl; DC: HDC);
procedure BMouseDown(Sender: PControl; var Mouse: TMouseEventData);
procedure ButtonMouseEnter(Sender: PObj);
procedure ButtonMouseleave(Sender: Pobj);
procedure ButtonMouseDblClk(Sender: PControl; var Mouse: TMouseEventData);

procedure BMouseUp(Sender: PControl; var Mouse: TMouseEventData);
public
constructor Create(AOwner: PControl; x, y, w, h: integer);
function MenuTus: PControl;
destructor Destroy; override;
published
property CerceveRenk: Tcolor Read FCerceveRenk Write SetCerceveRenk;
property Blend: extended Read FBlend Write SetBlend;

end;

implementation

{ TMenuTus2 }

function TMenuTus2.ColorBetween(C1, C2: TColor; blend: extended): TColor;
var
r, g, b: byte;

y1, y2: byte;
begin

C1 := Color2RGB(C1);
C2 := Color2RGB(C2);

y1 := GetRValue(C1);
y2 := GetRValue(C2);

r := Round(y1 + (y2 – y1) * blend);

y1 := GetGValue(C1);
y2 := GetGValue(C2);

g := Round(y1 + (y2 – y1) * blend);

y1 := GetBValue(C1);
y2 := GetBValue(C2);

b := Round(y1 + (y2 – y1) * blend);
Result := RGB(r, g, b);
end;

procedure TMenuTus2.SetBlend(const AValue: extended);
begin
if FBlend = AValue then
exit;
FBlend := AValue;
MenuTus.Invalidate;
end;

procedure TMenuTus2.ButtonMouseEnter(Sender: PObj);
begin
Fmouse := True;
FDurum := dUzerinde;
Button.Invalidate;

end;

procedure TMenuTus2.ButtonMouseleave(Sender: PObj);
begin

Fdurum := dNormal;
Fmouse := False;
Button.Invalidate;
end;

procedure TMenuTus2.ButtonMouseDblClk(Sender: PControl; var Mouse: TMouseEventData);
begin
FDurum := dBasildi;

Sender.Invalidate;
end;

constructor TMenuTus2.Create(AOwner: PControl; x, y, w, h: integer);
begin

Button := NewButton(AOwner, UTF8Decode(‘MenüTuş’));
button.Style := button.Style + BS_OWNERDRAW;
Button.Left := x;
Button.Top := y;
Button.Height := h;
Button.Width := w;
Fdurum := dNormal;
Button.Color := clRed;
FCerceveRenk := clBlack;
Fmouse := False;
FBlend := 0.4;
Button.Font.Color := clWhite;
Button.OnMouseDown := BMouseDown;
Button.OnMouseUp := BMouseUp;
Button.OnPaint := ButtonPaint;
Button.OnMouseEnter := ButtonMouseEnter;
Button.OnMouseLeave := ButtonMouseleave;
Button.OnMouseDblClk := ButtonMouseDblClk;

Button.Show;
end;

function TMenuTus2.MenuTus: PControl;
begin
Result := Button;
end;

procedure TMenuTus2.BMouseDown(Sender: PControl; var Mouse: TMouseEventData);
begin

FDurum := dBasildi;

Sender.Invalidate;

end;

procedure TMenuTus2.BMouseUp(Sender: PControl; var Mouse: TMouseEventData);
begin

if not Fmouse then
Fdurum := dNormal
else
Fdurum := dUzerinde;
Sender.Invalidate;

end;

procedure CerceveCiz(Sender: PControl; border: TRect);
begin
//InflateRect(border,-1,-1);

Sender.Canvas.MoveTo(border.Left, border.Top);
Sender.Canvas.LineTo(border.Right – 1, border.Top);
Sender.Canvas.LineTo(border.Right – 1, border.Bottom – 1);
Sender.Canvas.LineTo(border.Left, border.Bottom – 1);
Sender.Canvas.LineTo(border.Left, border.Top);

end;

procedure TMenuTus2.ButtonPaint(Sender: PControl; DC: HDC);
var
r: TRect;
renk2: TColor;
begin

r := Sender.ClientRect;
Sender.Canvas.Brush.BrushStyle := bsSolid;
Sender.Canvas.Brush.Color := Sender.Color;
Sender.Canvas.Pen.Color := Sender.Color;
Sender.Canvas.Rectangle(R.Left, r.Top, r.Right, r.Bottom);
renk2 := ColorBetween(Sender.Color, clWhite, FBlend);
r.Bottom := r.Bottom div 2;
Sender.Canvas.Brush.Color := renk2;
Sender.Canvas.Pen.Color := renk2;
Sender.Canvas.Rectangle(r.Left, r.top, r.Right, r.Bottom);

r := Sender.ClientRect;
SetBkMode(Sender.Canvas.Handle, TRANSPARENT);
SetTextColor(Sender.Canvas.Handle, Sender.Font.Color);

case Fdurum of
dNormal:
begin

DrawText(Sender.Canvas.Handle, pKOLChar(Sender.Caption), -1,
R, DT_SINGLELINE or DT_VCENTER or DT_CENTER);

end;
dUzerinde:
begin
DrawText(Sender.Canvas.Handle, PKOLChar(Sender.Caption), -1,
R, DT_SINGLELINE or DT_VCENTER or DT_CENTER);

Sender.Canvas.pen.Color := FCerceveRenk;
r := Sender.ClientRect;
CerceveCiz(Sender, r);
end;
dBasildi:
begin
OffsetRect(r, 1, 1);
DrawText(Sender.Canvas.Handle, PKOLChar(Sender.Caption), -1,
R, DT_SINGLELINE or DT_VCENTER or DT_CENTER);

Sender.Canvas.pen.Color := FCerceveRenk;
r := Sender.ClientRect;
CerceveCiz(Sender, r);

end;

end;

end;

procedure TMenuTus2.SetCerceveRenk(const Value: Tcolor);
begin
if FCerceveRenk <> Value then
begin
FCerceveRenk := Value;
Button.Invalidate;
end;
end;

destructor TMenuTus2.Destroy;
begin
inherited;
Button.Free;
end;

end.

[/code]

İlgili dosyalar:
menutus

Bir cevap yazın

E-posta hesabınız yayımlanmayacak. Gerekli alanlar * ile işaretlenmişlerdir