ana sayfa > Delphi > Delphide renkli bir button yapalım.

Delphide renkli bir button yapalım.

Salı, 24 Mar 2009 yorum ekle yorumlara git

Bu yazımızda Kol-Ce’ ye biraz ara verelim ve Delphi’ ye dönelim. Yaptığım bir projede renkli tuş gerekiyordu ve biraz uğraştıktan sonra gradient yapmaya karar verdim. Tümünü gradient yapınca pek güzel durmadı, bende Iphone telefonlarındaki table view lerde bulunan parçalı yani yarısını gradient diğer yarısınıda düz yapmaya karar verdim.

Ayrıca mouseover içinde belli bir değere göre hesaplayan bir fonksiyon buldum. Aşağıdaki fonksiyon iki rengin verilen bir alpha değeri kadar birbirine geçişini hesaplıyor. Bununla iki resmin birbiri üzerine saydam olarak çizebiliriz. Bu Microsoft’ un kullandığı BLENDFUNCTION biraz küçültülmüşü. Burada alpha değerini 255 e kadar hesaplama algoritması mevcut.

function ColorBetween(C1, C2: TColor; blend: Extended): TColor;
var
  r, g, b: Byte;

  y1, y2: Byte;
begin
  C1 := ColorToRGB(C1);
  C2 := ColorToRGB(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;

Bu bileşende iki türlü çizim mevcut birisi klasik dikdörtgen diğeride köşeli diktörtgen çiziyor. Köşeli diktörgen için Windows’ un SelectClipRgn apisini kullanarak çizim alanını kısıtladım.

Ekran görüntüsü:
parcali

unit ParcaliTus;

interface

uses
  SysUtils, Classes, Controls, windows, graphics, messages;
type
  TDurum = (dNormal, dUzerinde, dBasildi);
  TTipi = (tDikdortgen, tKoseli);

type
  TParcaliTus = class(TGraphicControl)
  private
    FDurum: TDurum;
    FTipi: TTipi;
    FKose: integer;
    procedure SetDurum(const Value: TDurum);
    procedure SetTipi(const Value: TTipi);
    procedure SetKose(const Value: integer);
  private
    FRenk: Tcolor;
    FZeminRenk: Tcolor;
    FPenRenk: tcolor;
    FNormalBlend: Extended;
    FUzeriBlend: Extended;
    procedure SetRenk(const Value: Tcolor);
    procedure SetZeminRenk(const Value: Tcolor);
    procedure SetPenRenk(const Value: tcolor);
    procedure SetNormalBlend(const Value: Extended);
    procedure SetUzeriBlend(const Value: Extended);
    property Durum: TDurum read FDurum write SetDurum;
    { Private declarations }
  protected
    procedure Paint; override;
    function ColorBetween(C1, C2: TColor; blend: Extended): TColor;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
      X: Integer; Y: Integer); override;
    procedure CMMouseenter(var Message: TMessage); message CM_MOUSEENTER;
    procedure CMMouseleave(var Message: TMessage); message CM_MOUSELEAVE;
    procedure CMFontchanged(var Message: TMessage); message CM_FONTCHANGED;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X: Integer;
      Y: Integer); override;
    procedure CMTextchanged(var Message: TMessage); message CM_TEXTCHANGED;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    property Renk: Tcolor read FRenk write SetRenk default ClRed;
    property ZeminRenk: Tcolor read FZeminRenk write SetZeminRenk default clWhite;
    property PenRenk: tcolor read FPenRenk write SetPenRenk default clBlack;
    property NormalBlend: Extended read FNormalBlend write SetNormalBlend;
    property UzeriBlend: Extended read FUzeriBlend write SetUzeriBlend;
    property Tipi: TTipi read FTipi write SetTipi default tDikdortgen;
    property Kose: integer read FKose write SetKose;
    property Font;
    property OnClick;
    property Caption;
    property Anchors;
    property Align;
  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents(‘NoktaBarkodC’, [TParcaliTus]);
end;

{ TParcaliTus }

constructor TParcaliTus.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  ControlStyle := ControlStyle + [csOpaque];
  FNormalBlend := 0.5;
  FUzeriBlend := 0.4;
  FKose := 20;
  FTipi := tDikdortgen;
  FRenk := clRed;
  FZeminRenk := clWhite;
  FPenRenk := clBlack;
  FDurum := dNormal;
  Font.Name := ‘Tahoma’;

end;

procedure GetRGB(Color: TColor; out R, G, B: Integer);
begin
  Color := ColorToRGB(Color);
  R := GetRValue(Color);
  G := GetGValue(Color);
  B := GetBValue(Color);
end;

function RGBToColor(R, G, B: Integer): TColor;
begin
  if R < 0 then R := 0 else if R > 255 then R := 255;
  if G < 0 then G := 0 else if G > 255 then G := 255;
  if B < 0 then B := 0 else if B > 255 then B := 255;
  Result := TColor(RGB(R, G, B));
end;

procedure Gradient(ACanvas: TCanvas; const ARect: TRect;
  C1, C2: TColor);
var
  I: Integer;
  r, g, b: Integer;
  rc1, gc1, bc1: Integer;
  rc2, gc2, bc2: Integer;
begin
  GetRGB(C1, rc1, gc1, bc1);
  GetRGB(C2, rc2, gc2, bc2);
  for I := 0 to ARect.Bottom do begin
      r := rc1 + (((rc2 – rc1) * I) div (ARect.Bottom – ARect.Top));
      g := gc1 + (((gc2 – gc1) * I) div (ARect.Bottom – ARect.Top));
      b := bc1 + (((bc2 – bc1) * I) div (ARect.Bottom – ARect.Top));
      ACanvas.Brush.Color := RGBToColor(r, g, b);
      ACanvas.FillRect(Rect(ARect.Left, ARect.Top + I, ARect.Right, ARect.Top + I + 1))
    end;
end;

procedure TParcaliTus.CMMouseenter(var Message: TMessage);
begin
  if csDesigning in ComponentState then exit;
  FDurum := dUzerinde;
  Invalidate;
end;

procedure TParcaliTus.CMMouseleave(var Message: TMessage);
begin
  if csDesigning in ComponentState then exit;
  FDurum := dNormal;
  Invalidate;

end;

function TParcaliTus.ColorBetween(C1, C2: TColor; blend: Extended): TColor;
var
  r, g, b: Byte;

  y1, y2: Byte;
begin
  C1 := ColorToRGB(C1);
  C2 := ColorToRGB(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;

destructor TParcaliTus.Destroy;
begin

  inherited;
end;

procedure TParcaliTus.MouseDown(Button: TMouseButton; Shift: TShiftState;
  X, Y: Integer);
begin
  FDurum := dBasildi;
  Invalidate;
  inherited MouseDown(Button, Shift, X, Y);

end;

procedure TParcaliTus.Paint;
var
  al: TRect;
  col2: TColor;
  rgn: Hrgn;
begin
  al := GetClientRect;

  with Canvas do
    begin
      if FTipi = tKoseli then
        begin
          rgn := CreateRoundRectRgn(Left, Top, left + Width, top + Height, FKose, FKose);
          SelectClipRgn(canvas.handle, rgn);
        end;
      Brush.Style := bsSolid;

      case Durum of
        dNormal:
          begin
            col2 := ColorBetween(FRenk, FZeminRenk, FNormalBlend);
            Brush.Color := col2;
            Pen.Color := col2;
            Rectangle(al);
            al.Top := al.Bottom div 2;
            Gradient(Canvas, al, FRenk, col2);
            al := ClientRect;
            Brush.Style := bsClear;
            DrawText(Canvas.Handle, pchar(Caption), -1, al, DT_SINGLELINE or DT_CENTER or DT_VCENTER);

          end;
        dUzerinde:
          begin
            col2 := ColorBetween(FRenk, FZeminRenk, FUzeriBlend);
            Brush.Color := col2;
            Pen.Color := col2;
            Rectangle(al);
            al.Top := al.Bottom div 2;
            Gradient(Canvas, al, FRenk, col2);
            al := ClientRect;
            Brush.Style := bsClear;
            DrawText(Canvas.Handle, pchar(Caption), -1, al, DT_SINGLELINE or DT_CENTER or DT_VCENTER);
          end;

        dBasildi:
          begin
            col2 := ColorBetween(FRenk, FZeminRenk, FNormalBlend);
            Brush.Color := col2;
            Pen.Color := col2;
            Rectangle(al);
            al.Top := al.Bottom div 2;
            Gradient(Canvas, al, FRenk, col2);
            al := ClientRect;
            OffsetRect(al, 1, 1);
            Brush.Style := bsClear;
            DrawText(Canvas.Handle, pchar(Caption), -1, al, DT_SINGLELINE or DT_CENTER or DT_VCENTER);

          end;

      end;

      al := ClientRect;
      Pen.Color := FPenRenk;
      Brush.Style := bsClear;
      if FTipi = tDikdortgen then Rectangle(al);
      if FTipi = tKoseli then
        begin
          SelectClipRgn(Canvas.Handle, 0);
          DeleteObject(rgn);
        end;
    end;
end;

procedure TParcaliTus.SetNormalBlend(const Value: Extended);
begin
  if FNormalBlend <> Value then
    begin
      FNormalBlend := Value;
      Invalidate;
    end;
end;

procedure TParcaliTus.SetPenRenk(const Value: tcolor);
begin
  if FPenRenk <> Value then
    begin
      FPenRenk := Value;
      Invalidate;
    end;
end;

procedure TParcaliTus.SetRenk(const Value: Tcolor);
begin
  if Renk <> Value then
    begin
      FRenk := Value;
      Invalidate;
    end;
end;

procedure TParcaliTus.SetUzeriblend(const Value: Extended);
begin
  if FUzeriBlend <> Value then
    begin
      FUzeriBlend := Value;
      Invalidate;
    end;
end;

procedure TParcaliTus.SetZeminRenk(const Value: Tcolor);
begin
  if ZeminRenk <> Value then
    begin
      FZeminRenk := Value;
      Invalidate;
    end;
end;

procedure TParcaliTus.SetDurum(const Value: TDurum);
begin
  FDurum := Value;
end;

procedure TParcaliTus.CMFontchanged(var Message: TMessage);
begin
  Canvas.Font.Assign(Font);
  Invalidate;
end;

procedure TParcaliTus.MouseUp(Button: TMouseButton; Shift: TShiftState; X,
  Y: Integer);
begin
  FDurum := dUzerinde;
  Invalidate;
  inherited MouseUp(Button, Shift, X, y);

end;

procedure TParcaliTus.CMTextchanged(var Message: TMessage);
begin
  Invalidate;
end;

procedure TParcaliTus.SetTipi(const Value: TTipi);
var
  al: TRect;
begin
  if FTipi <> Value then
    begin
      FTipi := Value;
      Invalidate;
      SetRect(al, Left, Top, Width, Height);
      InvalidateRect(Parent.Handle, @al, true);

    end;
end;

procedure TParcaliTus.SetKose(const Value: integer);
var
  al: TRect;
begin
  if FKose <> Value then
    begin
      FKose := Value;
      Invalidate;
      SetRect(al, Left, Top, Width, Height);
      InvalidateRect(Parent.Handle, @al, true);
    end;
end;

end.

Categories: Delphi Tags: , , ,
  1. şimdilik yorum yok.
  1. şimdilik geri bağlantı yok