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



  風の鳩サブレー さん、みなさん、こんにちは。

  #00699 と過去ログを参考に複数行表示ののPanelButton を作ってみました。

・Caption プロパティの文字列を一行または、二行にて表示する。
 （但し、左寄せ）
・文字列の短い場合は、垂直方向中央の１行表示。長くなると２行表示。
 （但し、フォントは、Height の半分の高さ）
・Caption := '123' + #13 + '456';  もＯＫ。
・TCustomPanel から継承し、以下のプロパティは非公開。
    Align, Alignment, BevelInner, BevelOuter,
    BevelWidth, BorderWidth, BorderStyle

・CM_DIALOGCHAR に対応してないです。


  P.S. Font.Height をもう少しうまくできないかな〜。



-----------------------------------------------------------------------


>>> CM_DIALOGCHAR に応えてやると可能になりますよ(^^)
>>> StdCtrls.pas の TButton.CMDialogChar が参考になると思います。
>>
>>対応してみました。(Lines プロパティの1行目のみ)


unit PanelButtonClass;

interface

uses
  Classes, Controls, ExtCtrls, Windows, Graphics;

type
  TPanelButton = class(TCustomPanel)
  private
    FPanelDown : boolean;
    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;
  public
    constructor Create(AOwner : TComponent); override;
  published
    // Align, Alignment, BevelInner, BevelOuter
    // BevelWidth, BorderWidth, BorderStyle
    property DragCursor;
    property DragMode;
    property Enabled;
    property FullRepaint;
    property Caption;
    property Color;
    property Ctl3D;
    property Font;
    property Locked;
    property ParentColor;
    property ParentCtl3D;
    property ParentFont;
    property ParentShowHint;
    property PopupMenu;
    property ShowHint;
    property TabOrder;
    property TabStop;
    property Visible;
    property OnClick;
    property OnDblClick;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDrag;
    property OnEnter;
    property OnExit;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property OnResize;
    property OnStartDrag;

  end;

procedure Register;

implementation


constructor TPanelButton.Create (AOwner : TComponent);
begin
  inherited Create(AOwner);
  width := 75;
  height := 27;
  BevelWidth := 2;
  FPanelDown := false;
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
    begin
      BevelOuter := bvRaised;
    end;
  end
  // ボタン上にカーソルが有り押されている場合はへこませる
  else if FPanelDown and (BevelOuter = bvRaised) then
  begin
    BevelOuter := bvLowered;
  end;
  inherited;
end;

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

//再描画処理　
procedure TPanelButton.paint;
var
  R: TRect;
  TopColor, BottomColor: TColor;

  procedure AdjustColors(Bevel: TPanelBevel);
  begin
    TopColor := clBtnHighlight;
    if Bevel = bvLowered then TopColor := clBtnShadow;
    BottomColor := clBtnShadow;
    if Bevel = bvLowered then BottomColor := clBtnHighlight;
  end;

  function InLFCR(S: string): boolean;
  var
    i: integer;
  begin
    Result := False;
    for i:=1 to Length(S) do
    begin
      if (S[i]=#10) or (S[i]=#13) then
      begin
        Result := True;
        Break;
      end;
    end;
  end;

  function InsertCR(S: string; CanvasWidth: integer): string;
  var
    tmp: string;
  begin
    Result := S;
    tmp := '';
    while (Self.Canvas.TextWidth(Result)>CanvasWidth) do
    begin
      if (Length(Result)>2) and IsDBCSLeadByte(Byte(Result[Length(Result)-
1])) then
      begin
        tmp := Copy(Result,Length(Result)-1,2) + tmp;
        Delete(Result,Length(Result)-1,2);
      end
      else
      begin
        tmp := Result[Length(Result)] + tmp;
        Delete(Result,Length(Result),1);
      end;
    end;
    Result := Result + #13 + tmp;
  end;

begin
  R := GetClientRect;
  if BevelOuter <> bvNone then
  begin
    AdjustColors(BevelOuter);
    Frame3D(Canvas, R, TopColor, BottomColor, BevelWidth);
  end;
  Frame3D(Canvas, R, Color, Color, BorderWidth);
  if BevelInner <> bvNone then
  begin
    AdjustColors(BevelInner);
    Frame3D(Canvas, R, TopColor, BottomColor, BevelWidth);
  end;
  with Canvas do
  begin
    Brush.Color := Color;
    FillRect(R);
    Brush.Style := bsClear;
    Font := Self.Font;
    // ２行表示できるFont.Height にする
    Font.Height := -((Self.Height-5) div 2);

    // 描画領域調整
    R := Rect(R.Left+1, R.Top+1, R.Right-1, R.Bottom-1);

    // 一行で描画する時は、描画範囲を小さくする
    if not InLFCR(Caption) and
       (TextWidth(Caption)<(R.Right-R.Left)) then
    begin
      R.Top := ((R.Bottom + R.Top) + Font.Height) div 2;
      R.Bottom := R.Top - Font.Height;
    end;
    // へこんでいる時の描画範囲
    if BevelOuter = bvLowered then
      R := Rect(R.Left+1, R.Top+1, R.Right+1, R.Bottom+1);

    if (TextWidth(Caption)>(R.Right-R.Left)) then
      DrawText(Self.Canvas.Handle, PChar(InsertCR(Caption, R.Right-R.Left)),
               -1, R, DT_VCENTER or DT_LEFT or DT_WORDBREAK)
    else
      DrawText(Self.Canvas.Handle, PChar(Caption),
               -1, R, DT_VCENTER or DT_LEFT or DT_WORDBREAK);
  end;
end;

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

end.

     牧原博司  hiroshi.makihara@nifty.ne.jp  - 99/08/14 (Sat) 23:37 -


Original document by 牧原　博司　　　氏 ID:(QZS03450)

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