delphi4arab منتديات دلفي للعرب

كيف أجعل الازرار button تأخد شكل دائري

السلام عليكم

أخي عذرا, لكن ليس لدي فكرة عن تحويل الزر إلى شكل دائري
لكن يمكن مثلا وضع صورة دائرية وعند الحدث On Click تجعل الصورة تتغير كما الحال في الزر, وتضع الكود المطلب انجازه
كما هو الحال مع مشغلات الميديا والملفات الصوتية

هذه بعض مكونات TButton معدلة:
الأول RVButton مكون زر يأخذ شكل دائري عند أطرافه.

PHP كود :
unit RVButton;

interface

uses
  SysUtils, Classes, Controls, Messages, Graphics, Windows;

const
  iOffset = 3;

type
  TRVButton = class(TGraphicControl)
  private
    FCaption : string;
    FButtonColor: TColor;
    FLButtonDown: boolean;
    FBtnPoints : array[1..2] of TPoint;
    FKRgn : HRgn;
    procedure SetCaption(Value: string);
    procedure SetButtonColor(Value: TColor);
    procedure FreeRegion;
  protected
    procedure Paint; override;
    procedure DrawCircle;
    procedure MoveButton;
    procedure WMLButtonDown(var Message: TWMLButtonDown); message WM_LBUTTONDOWN;
    procedure WMLButtonUp(var Message: TWMLButtonUp); message WM_LBUTTONUP;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    property ButtonColor: TColor read FButtonColor write SetButtonColor;
    property Caption: string read FCaption write SetCaption;
    property Enabled;
    property Font;
    property ParentFont;
    property ParentShowHint;
    property ShowHint;
    property Visible;
    property OnClick;
  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('Samples', [TRVButton]);
end;

{ TRVButton }

constructor TRVButton.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  ControlStyle := [csClickEvents,csCaptureMouse];
  Width := 50;
  Height := 50;
  FButtonColor := clBtnFace;
  FKRgn := 0;
  FLButtonDown := False;
end;

destructor TRVButton.Destroy;
begin
  if FKRgn <> 0 then FreeRegion;
  inherited Destroy;
end;

procedure TRVButton.DrawCircle;
begin
  FBtnPoints[1] := Point(iOffset,iOffset);
  FBtnPoints[2] := Point(Width - iOffset,Height - iOffset);
  FKRgn := CreateEllipticRgn(FBtnPoints[1].x,FBtnPoints[1].y,FBtnPoints[2].x,FBtnPoints[2].y);
  Canvas.Brush.Color := FButtonColor;
  FillRgn(Canvas.Handle,FKRgn,Canvas.Brush.Handle);
  MoveButton;
end;

procedure TRVButton.FreeRegion;
begin
  if FKRgn <> 0 then DeleteObject(FKRgn);
  FKRgn := 0;
end;

procedure TRVButton.MoveButton;
var
  Color1: TColor;
  Color2: TColor;
begin
  with Canvas do
    begin
    if not FLButtonDown then
      begin
      Color1 := clBtnHighlight;
      Color2 := clBtnShadow;
      end
    else
      begin
      Color1 := clBtnShadow;
      Color2 := clBtnHighLight;
      end;

      Pen.Width := 1;

      if FLButtonDown then Pen.Color := clBlack
      else                 Pen.Color := Color2;

      Ellipse(FBtnPoints[1].x - 2,FBtnPoints[1].y - 2,FBtnPoints[2].x + 2,FBtnPoints[2].y + 2);

      if not FLButtonDown then Pen.Width := 2
      else                     Pen.Width := 1;

      Pen.Color := Color1;

      Arc(FBtnPoints[1].x,FBtnPoints[1].y,FBtnPoints[2].x,FBtnPoints[2].y,
          FBtnPoints[2].x,FBtnPoints[1].y,FBtnPoints[1].x,FBtnPoints[2].y);

      Pen.Color := Color2;

      Arc(FBtnPoints[1].x,FBtnPoints[1].y,FBtnPoints[2].x,FBtnPoints[2].y,
          FBtnPoints[1].x,FBtnPoints[2].y,FBtnPoints[2].x,FBtnPoints[1].y);
      end;

  SetCaption('');
end;

procedure TRVButton.Paint;
begin
  inherited Paint;
  FreeRegion;
  DrawCircle;
end;

procedure TRVButton.SetButtonColor(Value: TColor);
begin
  if Value <> FButtonColor then
    begin
    FButtonColor := Value;
    Invalidate;
    end;
end;

procedure TRVButton.SetCaption(Value: string);
var
  X: Integer;
  Y: Integer;
begin
  if ((Value <> FCaption) and (Value <> '')) then
  begin
    FCaption := Value;
  end;

  with Canvas.Font do
  begin
    Name  := Font.Name;
    Size  := Font.Size;
    Style := Font.Style;
    if Self.Enabled then Color := Font.Color
    else
      Color := clDkGray;
  end;

  X := (Width div 2) - (Canvas.TextWidth(FCaption) div 2);
  Y := (Height div 2) - (Canvas.TextHeight(FCaption) div 2);
  Canvas.TextOut(X, Y, FCaption);
  //  Invalidate;
end;


procedure TRVButton.WMLButtonDown(var Message: TWMLButtonDown);
begin
  if not PtInRegion(FKRgn,Message.xPos,Message.yPos) then exit;
  FLButtonDown := True;
  MoveButton;
  inherited;
end;

procedure TRVButton.WMLButtonUp(var Message: TWMLButtonUp);
begin
  if not FLButtonDown then exit;
  FLButtonDown := False;
  MoveButton;
  inherited;
end;


end. 

الثاني: مكون ColorButton يدعم تغيير اللون وجعل شكله دائري وغير ذلك.

PHP كود :
unit ColorButton;

interface

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

type
  TColorButton = class(TButton)
  private
    FBackBeforeHoverColor: TColor;
  private
    FCanvas: TCanvas;
    IsFocused: Boolean;
    FBackColor: TColor;
    FForeColor: TColor;
    FHoverColor: TColor;
    procedure SetBackColor(const Value: TColor);
    procedure SetForeColor(const Value: TColor);
    procedure SetHoverColor(const Value: TColor);

    property BackBeforeHoverColor: TColor read FBackBeforeHoverColor
      write FBackBeforeHoverColor;
  protected
    procedure CreateParams(var Params: TCreateParams); override;
    procedure WndProc(var Message: TMessage); override;

    procedure SetButtonStyle(Value: Boolean); override;
    procedure DrawButton(Rect: TRect; State: UINT);

    procedure CMEnabledChanged(var Message: TMessage); message CM_ENABLEDCHANGED;
    procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
    procedure CNMeasureItem(var Message: TWMMeasureItem); message CN_MEASUREITEM;
    procedure CNDrawItem(var Message: TWMDrawItem); message CN_DRAWITEM;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;

  published
    property BackColor: TColor read FBackColor write SetBackColor default clBtnFace;
    property ForeColor: TColor read FForeColor write SetForeColor default clBtnText;
    property HoverColor: TColor read FHoverColor write SetHoverColor default clBtnFace;

  end;

procedure Register;

implementation


constructor TColorButton.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FCanvas := TCanvas.Create;
  BackColor := clBtnFace;
  ForeColor := clBtnText;
  HoverColor := clBtnFace;
end; (*Create*)

destructor TColorButton.Destroy;
begin
  FCanvas.Free;
  inherited Destroy;
end; (*Destroy*)

procedure TColorButton.WndProc(var Message: TMessage);
begin
  if (Message.Msg = CM_MOUSELEAVE) then
  begin
    BackColor := BackBeforeHoverColor;
    Invalidate;
  end;
  if (Message.Msg = CM_MOUSEENTER) then
  begin
    BackBeforeHoverColor := BackColor;

    BackColor := HoverColor;
    Invalidate;
  end;

  inherited;
end; (*WndProc*)

procedure TColorButton.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params);
  with Params do Style := Style or BS_OWNERDRAW;
end; (*CreateParams*)



procedure TColorButton.SetButtonStyle(Value: Boolean);
begin
  if Value <> IsFocused then
  begin
    IsFocused := Value;
    Invalidate;
  end;
end; (*SetButtonStyle*)

procedure TColorButton.CNMeasureItem(var Message: TWMMeasureItem);
begin
  with Message.MeasureItemStruct^ do
  begin
    itemWidth := Width;
    itemHeight := Height;
  end;
end; (*CNMeasureItem*)

procedure TColorButton.CNDrawItem(var Message: TWMDrawItem);
var
  SaveIndex: Integer;
begin
  with Message.DrawItemStruct^ do
  begin
    SaveIndex := SaveDC(hDC);
    FCanvas.Lock;
    try
      FCanvas.Handle := hDC;
      FCanvas.Font := Font;
      FCanvas.Brush := Brush;
      DrawButton(rcItem, itemState);
    finally
      FCanvas.Handle := 0;
      FCanvas.Unlock;
      RestoreDC(hDC, SaveIndex);
    end;
  end;
  Message.Result := 1;
end; (*CNDrawItem*)

procedure TColorButton.CMEnabledChanged(var Message: TMessage);
begin
  inherited;
  Invalidate;
end; (*CMEnabledChanged*)

procedure TColorButton.CMFontChanged(var Message: TMessage);
begin
  inherited;
  Invalidate;
end; (*CMFontChanged*)


procedure TColorButton.SetBackColor(const Value: TColor);
begin
  if FBackColor <> Value then
  begin
    FBackColor := Value;
    Invalidate;
  end;
end; (*SetButtonColor*)

procedure TColorButton.SetForeColor(const Value: TColor);
begin
  if FForeColor <> Value then
  begin
    FForeColor := Value;
    Invalidate;
  end;
end; (*SetForeColor*)

procedure TColorButton.SetHoverColor(const Value: TColor);
begin
  if FHoverColor <> Value then
  begin
    FHoverColor := Value;
    Invalidate;
  end;
end; (*SetHoverColor*)

procedure TColorButton.DrawButton(Rect: TRect; State: UINT);
var
  Flags, OldMode: Longint;
  IsDown, IsDefault, IsDisabled: Boolean;
  OldColor: TColor;
  OrgRect: TRect;
  rgn: HRGN;
begin
  OrgRect := Rect;
  Flags := DFCS_BUTTONPUSH or DFCS_ADJUSTRECT;
  IsDown := State and ODS_SELECTED <> 0;
  IsDefault := State and ODS_FOCUS <> 0;
  IsDisabled := State and ODS_DISABLED <> 0;
  if IsDown then Flags := Flags or DFCS_PUSHED;
  if IsDisabled then Flags := Flags or DFCS_INACTIVE;

  if IsFocused or IsDefault then
  begin
    FCanvas.Pen.Color := clWindowFrame;
    FCanvas.Pen.Width := 1;
    FCanvas.Brush.Style := bsClear;

    FCanvas.Rectangle(Rect.Left, Rect.Top, Rect.Right, Rect.Bottom);
    InflateRect(Rect, - 1, - 1);
  end;

  if IsDown then
  begin
    FCanvas.Pen.Color := clBtnShadow;
    FCanvas.Pen.Width := 1;
    FCanvas.Brush.Color := clBtnFace;
    FCanvas.Rectangle(Rect.Left, Rect.Top, Rect.Right, Rect.Bottom);
    InflateRect(Rect, - 1, - 1);
  end
  else
  begin
    DrawFrameControl(FCanvas.Handle, Rect, DFC_BUTTON, Flags);
  end;

  if IsDown then OffsetRect(Rect, 1, 1);

  OldColor := FCanvas.Brush.Color;
  FCanvas.Brush.Color := BackColor;
  FCanvas.FillRect(Rect);
  FCanvas.Brush.Color := OldColor;
  OldMode := SetBkMode(FCanvas.Handle, TRANSPARENT);
  FCanvas.Font.Color := ForeColor;
  if IsDisabled then
    DrawState(FCanvas.Handle, FCanvas.Brush.Handle, nil, Integer(Caption), 0,
    ((Rect.Right - Rect.Left) - FCanvas.TextWidth(Caption)) div 2,
    ((Rect.Bottom - Rect.Top) - FCanvas.TextHeight(Caption)) div 2,
      0, 0, DST_TEXT or DSS_DISABLED)
  else
    DrawText(FCanvas.Handle, PChar(Caption), - 1, Rect,
      DT_SINGLELINE or DT_CENTER or DT_VCENTER);

  SetBkMode(FCanvas.Handle, OldMode);

  if IsFocused and IsDefault then
  begin
    Font.Style := Font.Style + [fsBold];
  end
  else
  begin
    Font.Style := Font.Style - [fsBold];
  end;

  rgn := CreateRoundRectRgn(3,3,Width - 2,Height - 2,10,10);
  SetWindowRgn(Handle, rgn, True);
end; (*DrawButton*)

procedure Register;
begin
  RegisterComponents('Samples', [TColorButton]);
end;

end. 

السلام عليكم
كيف استخدمه اذا كان على شكل Unit ؟
وشكرا

وعليكم السلام ورحمة الله

إقتباس :كيف استخدمه اذا كان على شكل Unit ?

تقوم أولا بإنشاء مكون حيث هذه Unit هي مصدره
ثم تثبته على الدلفي وتستعمله كما تستعمل أي مكون آخر.
طريقة إنشاء المكونات في الدرس السادس من دروس الدورة.

السلام عليكم

او
دالة بسيطة لتغير شكله الى دئرة و مقروطة Smile

كود :
Function Shape_Bounds(Btn: TButton; Polygon_Elliptic: Byte): Integer;
var
  P: array[1..4]of TPoint;
begin
  with Btn do
  begin
    case Polygon_Elliptic of
      0:
         begin
           P[1].X := Round(ClientWidth / 2);
           P[1].Y := 0;

           P[2].X := 0;
           P[2].Y := Round(ClientHeight / 2);

           P[3].X := Round(ClientWidth / 2);
           P[3].Y := ClientHeight;

           P[4].X := ClientWidth;
           P[4].Y := Round(ClientHeight / 2);

           Result := CreatePolygonRgn(P, 4, POLYFILL_LAST);
         end;
      1: Result := CreateEllipticRgn(0, 0, Width, Height);
    end;
    SetWindowRgn(Handle, Result, True);
  end;
end;[/PHP]

[PHP]
procedure TForm1.btn3Click(Sender: TObject);
begin
  Shape_Bounds(btn1, 0);  //دائرة
  Shape_Bounds(btn2, 1);  //مقروطى
end;

السلام عليكم

نفس سؤال هذا الموضوع
لاكن على اى مكون ينحدر من TGraphicControl (مثلا Image) مع تفادى تنفيد حدث تحرك الفئرة فى اطراف هذا المكون .

mohamed_it

Dr.MOT

kachwahed

kachwahed

Dr.MOT

kachwahed

hanipino

hanipino