ana sayfa > Kol-Ce, Lazarus > Kol-ce runtime farklı tuş oluşturma.

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

Cumartesi, 28 Ağu 2010 yorum ekle yorumlara git

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:

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.Right1, border.Top);
  Sender.Canvas.LineTo(border.Right1, border.Bottom1);
  Sender.Canvas.LineTo(border.Left, border.Bottom1);
  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.

İlgili dosyalar:
menutus

Categories: Kol-Ce, Lazarus Tags:
  1. şimdilik yorum yok.
  1. şimdilik geri bağlantı yok