Мастера, как правильно сделать подчёркивание надписи на SpeedButton

← →
Катя (2002-02-20 13:24) [0]

делаю так, подчёркивается, но потом не убирается черта.
procedure TForm1.SpeedButton1MouseMove(Sender: TObject; Shift: TShiftState;
X, Y: Integer);
begin
SpeedButton1.Font.Style:=[fsUnderline];
end;

← →
Юрий Зотов (2002-02-20 13:46) [1]

А почему она должна убираться, если Вы ее нигде не убираете?

Попробуйте вот что.

type
TForm1 = class(TForm)
...
private
procedure CMMouseEnter(var Message: TMessage); message CM_MOUSEENTER;
procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE;
...
end;

procedure TForm1.CMMouseEnter(var Message: TMessage);
begin
if Message.LParam = Integer(SpeedButton1) then
with SpeedButton1.Font do Style := Style + [fsUnderline];
inherited
end;

procedure TForm1.CMMouseLeave(var Message: TMessage);
begin
if Message.LParam = Integer(SpeedButton1) then
with SpeedButton1.Font do Style := Style - [fsUnderline];
inherited
end;

← →
Катя (2002-02-20 20:42) [2]

Спасибо, Юрий, ошибку не выдаёт, но и не работает :(

← →
reonid (2002-02-22 22:31) [3]

Возможно, кнопка лежит не непосредственно на форме
(т.е. парентом кнопки является другой контрол, напр. панель )
- тогда для её парента можно переписать оконную процедуру,
добавив обработку сообщений CM_MOUSEENTER/CM_MOUSELEAVE
от конкретной кнопки.

На самом деле гораздо проще написать наследника кнопки с
обработчиками сообщений CM_MOUSEENTER/CM_MOUSELEAVE.
Проблема состоит в том, что не хочется захламлять панель компонентов различным хламом, нужным только для одного приложения.

Можно ещё написать новый компонент, и, не регистрируя его в
среде, заменить им уже существующий в реалтайме.
(сохранив св-ва и обработчики событий старого,
которые были установлены в дизайнтайме).

Я тут немного поизвращался на эту тему.

unit Unit1;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
Buttons, ExtCtrls, {rtti,} TypInfo, StdCtrls, Menus;

type
TForm1 = class(TForm)
Panel1: TPanel; // на ней лежат кнопки
SpeedButton1: TSpeedButton; // подчеркивание реализуется через замену оконной процедуры парента
BTest: TSpeedButton; // подчеркивание реализовано через наследника
ListBox1: TListBox;
PopupMenu1: TPopupMenu;
N11: TMenuItem;
N21: TMenuItem;
N31: TMenuItem;
procedure FormCreate(Sender: TObject);
procedure BTestClick(Sender: TObject);
private
FOldBtnParentWndProc: TWndMethod;
public
procedure NewBtnParentWndProc(var Message: TMessage);
end;

TMyBtn = class(TSpeedButton)
private
procedure CMMouseEnter(var Message: TMessage); message CM_MOUSEENTER;
procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE;
end;

procedure UpgradeComponent(OldCmp: TComponent; NewCmpClass: TComponentClass);

var
Form1: TForm1;
OldF, NewF: TFont;

implementation

{$R *.DFM}

procedure UpgradeComponent(OldCmp: TComponent; NewCmpClass: TComponentClass);
var NewCmp: TComponent;
CmpName: string;
Cls: TClass;
i: Integer;

PropCnt: Integer;
PropList: PPropList;
PropInfo: PPropInfo;

function IsField(PropProc: Pointer): Boolean;
type ba = array[0..3]of Byte;
begin
Result := ba(PropProc)[3] > $FE;
end;
begin
if not NewCmpClass.InheritsFrom(OldCmp.ClassType) then
raise Exception.CreateFmt("Cannot upgrade %s to %s",
[OldCmp.ClassName, NewCmpClass.ClassName]);

NewCmp := NewCmpClass.Create(OldCmp.Owner);

PropCnt := GetTypeData(OldCmp.ClassInfo)^.PropCount;
GetMem(PropList, PropCnt*SizeOf(Pointer));

try
GetPropInfos(OldCmp.ClassInfo, PropList);

for i := 0 to PropCnt-1 do
begin
PropInfo := PropList^[i];
if (PropInfo^.Name <> "Name") then
begin
if PropInfo^.PropType^^.Kind = tkMethod then
SetMethodProp(NewCmp, PropInfo,
GetMethodProp(OldCmp, PropInfo))
else if PropInfo^.PropType^^.Kind = tkClass then
begin
Cls := GetTypeData(PropInfo^.PropType^).ClassType;
if (not Cls.InheritsFrom(TComponent)) and
(Cls.InheritsFrom(TPersistent)) and
IsField(PropInfo^.SetProc)
then
// По непонятной причине свойство
// property Constraints: TSizeConstraints read FConstraints write FConstraints;
// производит запись прямо в поле, а не через Set-метод + Assign
// Поэтому приходится делать обходной маневр.
TPersistent(GetObjectProp(NewCmp, PropInfo)).Assign
(TPersistent(GetObjectProp(OldCmp, PropInfo)))
else
begin
SetObjectProp(NewCmp, PropInfo,
GetObjectProp(OldCmp, PropInfo));
end;
end
else
SetPropValue(NewCmp, PropInfo^.Name, GetPropValue(OldCmp, PropInfo^.Name));
end;
end;
finally
FreeMem(PropList, PropCnt*SizeOf(Pointer));
end;

CmpName := OldCmp.Name;
if OldCmp is TControl then
with TControl(OldCmp) do
begin
TControl(NewCmp).Parent := Parent;
TControl(NewCmp).Visible := Visible;
TControl(NewCmp).Enabled := Enabled;
Hide;
end;

OldCmp.Free;
NewCmp.Name := CmpName; // -> NewCmp.SetReference
end;

← →
reonid (2002-02-22 22:32) [4]

// продолжение

procedure TForm1.NewBtnParentWndProc(var Message: TMessage);
begin
if (Message.Msg = CM_MOUSEENTER) or (Message.Msg = CM_MOUSELEAVE) then
begin
if Pointer(Message.LParam) = SpeedButton1 then
begin
if Message.Msg = CM_MOUSEENTER then
with SpeedButton1.Font do Style := Style + [fsUnderline]
else
with SpeedButton1.Font do Style := Style - [fsUnderline];
end;
end;
FOldBtnParentWndProc(Message);
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
FOldBtnParentWndProc := TWinControl(SpeedButton1.Parent).WindowProc;
TWinControl(SpeedButton1.Parent).WindowProc := NewBtnParentWndProc;

UpgradeComponent(BTest, TMyBtn);
end;

{ TMyBtn }

procedure TMyBtn.CMMouseEnter(var Message: TMessage);
begin
with Font do Style := Style + [fsUnderline];
inherited;
end;

procedure TMyBtn.CMMouseLeave(var Message: TMessage);
begin
with Font do Style := Style - [fsUnderline];
inherited;
end;

procedure TForm1.BTestClick(Sender: TObject);
begin
ShowMessage("Test: "+BTest.Name); // BTest ссылается уже на новый компонент
end;

end.

← →
Набережных С. (2002-02-23 09:15) [5]

Не худо-бы сначало поискать в ответах, а потом спрашивать...
private FOld:TWndMethod; procedure NewSBProc(var Msg: TMessage); procedure TForm.FormCreate(Sender: TObject); begin FOld:=SpeedButton1.WindowProc; SpeedButton1.WindowProc:=NewSBProc; end; procedure TForm.NewSBProc(var Msg: TMessage); begin FOld(Msg); case Msg.Msg of CM_MOUSEENTER: with SpeedButton1.Font do Style:=Style + [fsUnderline]; CM_MOUSELEAVE: with SpeedButton1.Font do Style:=Style - [fsUnderline]; end; end;

> reonid © (22.02.02 22:31)

> Я тут немного поизвращался на эту тему.

Это точно.

Мастера, как правильно сделать подчёркивание надписи на SpeedButton Найти похожие ветки