お知らせ

電子会議

ライブラリ

パレット

Delphi FAQ検索

Delphi FAQ一覧

サンプル蔵





FDelphi FAQ
16番会議室「玉石混淆みんなで作るSample蔵」に寄せられたサンプル

"RE:複数行のキャプション表示ボタン"

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

風の鳩サブレー さん、みなさん、こんにちは。 #00699 と過去ログを参考に複数行表示ののPanelButton を作ってみました。 ・Caption プロパティの文字列を一行または、二行にて表示する。 (但し、左寄せ) ・文字列の短い場合は、垂直方向中央の1行表示。長くなると2行表示。 (但し、フォントは、Height の半分の高さ) ・Caption := '123' + #13 + '456'; もOK。 ・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; // 2行表示できる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蔵」に投稿されたサンプルです。これらのサンプルはボーランド株式会社がサポートする公式のものではありません。また、必ずしも動作が検証されているものではありません。これらのサンプルを使用したことに起因するいかなる損害も投稿者、およびフォーラムスタッフはその責めを負いません。使用者のリスクの範疇でご使用下さい。

Copyright 1996-2002 Delphi Users' Forum