کپشن عمودی باتن

[Mask]

با سلام به دوستان.
چطوری میتونم یه باتن رو به صورت عمودی متنشو بنویسم.

[Felony]

با Button خود دلفی نمیتونی چون خودش همچین Property نداره و از کلاس TGraphicControl هم مشتق نشده که Canvas داشته باشه و بشه متن رو روش رسم کرد ، یا باید خودت دست به کار بشی و همچین Button ی درست کنه که از TGraphicControl مشتق شده باشه یا باید از ابزار دیگه ای استفاده کنی که Canvas داشته باشه یا باید دنبال کامپوننت آماده بگردی .

اگر خواستی خودت کامپوننت رو بنویسی یا از کامپوننتی که Canvas داره استفاده کنی و متن رو روش رسم کنی میتونی از کد زیر استفاده کنی :

procedure AngleTextOut(ACanvas: TCanvas; Angle, X, Y: Integer; Text: string);
var
NewFontHandle,
OldFontHandle: hFont;
LogRec : TLogFont;
begin
GetObject(ACanvas.Font.Handle, SizeOf(LogRec), Addr(LogRec));
LogRec.lfEscapement := Angle * 10;
LogRec.lfOrientation := LogRec.lfEscapement;
NewFontHandle := CreateFontIndirect(LogRec);
OldFontHandle := SelectObject(ACanvas.Handle, NewFontHandle);
ACanvas.TextOut(X, Y, Text);
NewFontHandle := SelectObject(ACanvas.Handle, OldFontHandle);
DeleteObject(NewFontHandle);
end;

این هم نمونه استفاده :

AngleTextOut(Image1.Canvas, 90, 50, 50, 'Test string');

[SAASTN]

اینم برای اضافه کردن Canvas به TButton:
type
TVerticalButton = class(TCustomButton)
private
FCanvas: TCanvas;
property Canvas: TCanvas read FCanvas;
protected
procedure SetParent(AParent: TWinControl); override;
procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
end;

...

{ TVerticalButton }

constructor TVerticalButton.Create(AOwner: TComponent);
begin
inherited;
FCanvas := TCanvas.Create;
end;

destructor TVerticalButton.Destroy;
begin
FCanvas.Free;
inherited;
end;

procedure TVerticalButton.SetParent(AParent: TWinControl);
begin
inherited;
if Assigned(AParent) then
Canvas.Handle := GetDC(Handle);
end;

procedure TVerticalButton.WMPaint(var Message: TWMPaint);
begin
inherited;
FCanvas.Pen.Color := clBlack;
FCanvas.MoveTo(0, 0);
FCanvas.LineTo(10, 10);
end;

[Mask]

ممنون از شما.
من تا جالا کامپوننت ننوشتم.
اگه ممکنه کمک کنید.
برای اولین بار :لبخند: کامپوننت زیر رو نوشتم. اما چرا هیچ متد یا ایونتی نداره پس؟

unit UCUButton;

interface

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

type
TVerticalButton = class(TCustomButton)
private
FCanvas: TCanvas;
property Canvas: TCanvas read FCanvas;
protected
procedure SetParent(AParent: TWinControl); override;
procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
end;

procedure Register;

implementation

procedure Register;
begin
RegisterComponents('CUButton', [TVerticalButton]);
end;

{ TVerticalButton }

constructor TVerticalButton.Create(AOwner: TComponent);
begin
inherited;
FCanvas := TCanvas.Create;
end;

destructor TVerticalButton.Destroy;
begin
FCanvas.Free;
inherited;
end;

procedure TVerticalButton.SetParent(AParent: TWinControl);
begin
inherited;
if Assigned(AParent) then
Canvas.Handle := GetDC(Handle);
end;

procedure TVerticalButton.WMPaint(var Message: TWMPaint);
begin
inherited;
FCanvas.Pen.Color := clBlack;
FCanvas.MoveTo(0, 0);
FCanvas.LineTo(10, 10);
end;

end.

[Felony]

کدت تقریبا همچین چیزی میشه :

unit VB;

interface

uses
Windows, Messages, SysUtils, Classes, Vcl.Controls, Vcl.StdCtrls, Vcl.Graphics;

type
TVerticalButton = class(TButton)
private
FCanvas: TCanvas;
property Canvas: TCanvas read FCanvas;
protected
procedure SetParent(AParent: TWinControl); override;
procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
published
property Action;
property Align;
property Anchors;
property BiDiMode;
property Cancel;
property Caption;
property CommandLinkHint;
property Constraints;
property Default;
property DisabledImageIndex;
property DoubleBuffered;
property DragCursor;
property DragKind;
property DragMode;
property DropDownMenu;
property ElevationRequired;
property Enabled;
property Font;
property HotImageIndex;
property ImageAlignment;
property ImageIndex;
property ImageMargins;
property Images;
property ModalResult;
property ParentBiDiMode;
property ParentDoubleBuffered;
property ParentFont;
property ParentShowHint;
property PopupMenu;
property PressedImageIndex;
property SelectedImageIndex;
property ShowHint;
property Style;
property StylusHotImageIndex;
property TabOrder;
property TabStop;
property Visible;
property WordWrap;
property OnClick;
property OnContextPopup;
property OnDragDrop;
property OnDragOver;
property OnDropDownClick;
property OnEndDock;
property OnEndDrag;
property OnEnter;
property OnExit;
property OnKeyDown;
property OnKeyPress;
property OnKeyUp;
property OnMouseActivate;
property OnMouseDown;
property OnMouseEnter;
property OnMouseLeave;
property OnMouseMove;
property OnMouseUp;
property OnStartDock;
property OnStartDrag;
end;

procedure Register;

implementation

procedure Register;
begin
RegisterComponents('CUButton', [TVerticalButton]);
end;

{ TVerticalButton }

constructor TVerticalButton.Create(AOwner: TComponent);
begin
inherited;
FCanvas := TCanvas.Create;
end;

destructor TVerticalButton.Destroy;
begin
FCanvas.Free;
inherited;
end;

procedure TVerticalButton.SetParent(AParent: TWinControl);
begin
inherited;
if Assigned(AParent) then
Canvas.Handle := GetDC(Handle);
end;

procedure TVerticalButton.WMPaint(var Message: TWMPaint);
var
NewFontHandle,
OldFontHandle: hFont;
LogRec : TLogFont;
begin
inherited;
GetObject(FCanvas.Font.Handle, SizeOf(LogRec), Addr(LogRec));
LogRec.lfEscapement := 900;
LogRec.lfOrientation := LogRec.lfEscapement;
NewFontHandle := CreateFontIndirect(LogRec);
OldFontHandle := SelectObject(FCanvas.Handle, NewFontHandle);
FCanvas.Brush.Style:= bsClear;
FCanvas.TextOut((Self.Width div 2), ((Self.Height div 2) - (FCanvas.TextWidth(Caption)) div 2), Caption);
NewFontHandle := SelectObject(FCanvas.Handle, OldFontHandle);
DeleteObject(NewFontHandle);
end;

end.

[Mask]

داش مجتبی دمت گرم.
خیلی عالیه.
فقط چنتا نکته رو اگه اصلاح کنیم. این کامپوننت واسه خودش عالی میشه.
اول اینکه ما نیاز به کپشن افقی نداریم. چطوری میشه حذفش کرد و فقط کپشن عمودی بمونه.
و نکته بعدی مشکل در جای نمایش متن هست. یعنی اینکه کپشن عمودی باتن ، اگه مثل کپشن افقی از وسط نوشته بشه ، خیلی بهتره.
ممنون از کمکت.

[Felony]

یکم هم خودتون تلاش کنید ، برای قرار دادن متن در وسط که باید کمی محاسبات ریاضی بکنید و برای حذف Caption افقی هم 2 راه دارید ، یا Button رو از TGraphicControlمشتق کنید و بسازیدش که کلا پراپرتی Caption افقی رو نداشته باشه یا خودتون یک پراپرتی Caption عمودی هم به Button اضافه کنید و از هر کدوم که خواستید استفاده کنید .

در کد زیر مکان قرار گیری متن تصحیح شده و یک پراپرتی هم به نام VerticalCaption اضافه شده :

unit VB;

interface

uses
Windows, Messages, SysUtils, Classes, Vcl.Controls, Vcl.StdCtrls,
Vcl.Graphics;

type
TVerticalButton = class(TButton)
private
FCaption: TCaption;
FCanvas: TCanvas;
function GetVertCaption: TCaption;
procedure SetVertCaption(const Value: TCaption);
property Canvas: TCanvas read FCanvas;
protected
procedure SetParent(AParent: TWinControl); override;
procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
published
property VerticalCaption: TCaption read GetVertCaption write SetVertCaption;
property Action;
property Align;
property Anchors;
property BiDiMode;
property Cancel;
property CommandLinkHint;
property Constraints;
property Default;
property DisabledImageIndex;
property DoubleBuffered;
property DragCursor;
property DragKind;
property DragMode;
property DropDownMenu;
property ElevationRequired;
property Enabled;
property Font;
property HotImageIndex;
property ImageAlignment;
property ImageIndex;
property ImageMargins;
property Images;
property ModalResult;
property ParentBiDiMode;
property ParentDoubleBuffered;
property ParentFont;
property ParentShowHint;
property PopupMenu;
property PressedImageIndex;
property SelectedImageIndex;
property ShowHint;
property Style;
property StylusHotImageIndex;
property TabOrder;
property TabStop;
property Visible;
property WordWrap;
property OnClick;
property OnContextPopup;
property OnDragDrop;
property OnDragOver;
property OnDropDownClick;
property OnEndDock;
property OnEndDrag;
property OnEnter;
property OnExit;
property OnKeyDown;
property OnKeyPress;
property OnKeyUp;
property OnMouseActivate;
property OnMouseDown;
property OnMouseEnter;
property OnMouseLeave;
property OnMouseMove;
property OnMouseUp;
property OnStartDock;
property OnStartDrag;
end;

procedure Register;

implementation

procedure Register;
begin
RegisterComponents('CUButton', [TVerticalButton]);
end;

{ TVerticalButton }

constructor TVerticalButton.Create(AOwner: TComponent);
begin
inherited;
FCanvas := TCanvas.Create;
end;

destructor TVerticalButton.Destroy;
begin
FCanvas.Free;
inherited;
end;

function TVerticalButton.GetVertCaption: TCaption;
begin
Result := FCaption;
end;

procedure TVerticalButton.SetVertCaption(const Value: TCaption);
begin
FCaption := Value;
end;

procedure TVerticalButton.SetParent(AParent: TWinControl);
begin
inherited;
if Assigned(AParent) then
Canvas.Handle := GetDC(Handle);
end;

procedure TVerticalButton.WMPaint(var Message: TWMPaint);
var
NewFontHandle, OldFontHandle: hFont;
LogRec: TLogFont;
begin
inherited;
GetObject(FCanvas.Font.Handle, SizeOf(LogRec), Addr(LogRec));
LogRec.lfEscapement := 900;
LogRec.lfOrientation := LogRec.lfEscapement;
NewFontHandle := CreateFontIndirect(LogRec);
OldFontHandle := SelectObject(FCanvas.Handle, NewFontHandle);
FCanvas.Brush.Style := bsClear;
FCanvas.TextOut(((Self.Width - FCanvas.TextHeight(FCaption)) div 2),
(Self.Height - ((Self.Height div 2) - Canvas.TextWidth(FCaption) div 2)),
FCaption);
NewFontHandle := SelectObject(FCanvas.Handle, OldFontHandle);
DeleteObject(NewFontHandle);
end;

end.