この発言は
#00692　風の鳩サブレー  さんの複数行のキャプション表示ボタン
に対するコメントです





何度もすみません。

>>コンポセミナーにもいったことだし、TPanelから発生した
>>ボタンコンポーネントを作ってみました。
>>これだとボタンやキャプションの色、べベルの幅も変えられます。

>ボタンに複数行のキャプション表示を追加しました。
>Lines プロパティに設定した文字列リストがボタン表面に表示されます。
>Captionプロパティは無視します(^^;

>欠点としては
>１．フォーカスをもてない。
>２．アクセラレータキーが使えない。
>でしょうか。

改良点

１．表示文字列の幅の取得をする事によりキャプションの表示位置が
　　正確になりました。
２．Alignment プロパティに対応してキャプションの表示位置を
　　右寄せ、中央揃え、左寄せに設定できるようにしました。


unit PanelButton;

interface

uses
  Classes, Controls, ExtCtrls;

type
  TPanelButton = class(TPanel)
  private
    FPanelDown : boolean;
    FLines : TStrings;
    procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
    procedure MouseDown(Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer); override;
    procedure MouseUp(Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer); override;
    procedure Click; override;
    procedure paint; override;
    function  GetLines : TStrings;
    procedure SetLines(Value: TStrings);
  public
    constructor Create(AOwner : TComponent); override;
    destructor Destroy; override;
  published
    property Lines : TStrings read GetLines write SetLines;
  end;

procedure Register;

implementation


constructor TPanelButton.Create (AOwner : TComponent);
begin
  inherited Create(AOwner);
  width := 75;
  height := 25;
  FPanelDown := false;
  Flines := TStringList.create;
end;

destructor TPanelButton.Destroy;
begin
  Flines.Free;
  inherited Destroy;
end;


procedure TPanelButton.MouseDown(Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  BevelOuter := bvLowered;
  FPanelDown := true;
  inherited;
end;

procedure TPanelButton.MouseUp(Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  BevelOuter := bvRaised;
  FPanelDown := false;
  inherited;
end;

procedure TPanelButton.MouseMove(Shift: TShiftState; X,Y: Integer);
begin
// ボタン上にカーソルが無いときは押されていない状態にする
  if ((x < 0) or (y < 0) or (x > width) or (y > height)) then
  begin
    if BevelOuter = bvLowered then
      BevelOuter := bvRaised;
  end
// ボタン上にカーソルが有り押されている場合はへこませる
  else if FPanelDown and (BevelOuter = bvRaised) then
      BevelOuter := bvLowered;
    inherited;
end;

procedure TPanelButton.Click;
begin
  BevelOuter := bvRaised;
  FPanelDown := false;
  inherited;
end;

//再描画処理　
procedure TPanelButton.paint;
var ys,xs,i,line_count,ww,fh : integer;
begin
  caption := '';
  line_count := Lines.Count;
  if line_count = 0 then
    FLines.add(name);
  inherited;
  line_count := Lines.Count;
  fh := abs(Font.Height);
  ys := (height - (fh * line_count)) div 2;
  if ys < 0 then
    ys := 0;
  for i := 1 to line_count do
  begin
    ww := canvas.TextWidth(FLines[i-1]);
    Case Alignment of
      taCenter : xs := (width - ww) div 2;
      taLeftJustify : xs := Self.BevelWidth + 1;
      taRightJustify : xs := width - ww - Self.BevelWidth - 1;
    end;
    if xs < 0 then
      xs := 0;
    canvas.TextOut(xs,ys+(i-1)*fh,Flines[i-1]);
  end;
end;



procedure TPanelButton.SetLines(Value : TStrings);
begin
  FLines.Assign(Value);
  paint;
end;

function TPanelButton.GetLines : TStrings;
begin
  result := FLines;
end;


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

end.

風の鳩サブレー (JBG03220)

Original document by 風の鳩サブレー  氏 ID:(JBG03220)

ここにあるドキュメントは NIFTY SERVEの Delphi Users' Forum の16番会議室「玉石混淆みんなで作るSample蔵」に投稿されたサンプルです。これらのサンプルはボーランド株式会社がサポートする公式のものではありません。また、必ずしも動作が検証されているものではありません。これらのサンプルを使用したことに起因するいかなる損害も投稿者、およびフォーラムスタッフはその責めを負いません。使用者のリスクの範疇でご使用下さい。