Вопрос # 2 357: …сперты! Помогите пожалуйста с созданием нового компонента от компонен… (Работа с компонентами и библиотеками)

Приветствую, уважаемые эксперты!
Помогите пожалуйста с созданием нового компонента от компонента SpeedButton.
Нужно чтобы это был ГиперЛинкSpeedButton чтоб вводить www.адрес в инспекторе объекта в созданом поле weblinck...по типу ниже приведённого юнита для КонтрБатона:

Приложение:

unit LinkButton;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, shellapi;
type
TLinkButton = class(TButtonControl)
private
FDefault: Boolean;
FCancel: Boolean;
FActive: Boolean;
FLink: string;
procedure SetLink(const Value: string);
procedure btnclick(Sender: TObject);
procedure CMDialogKey(var Message: TCMDialogKey); message CM_DIALOGKEY;
procedure CMDialogChar(var Message: TCMDialogChar); message CM_DIALOGCHAR;
procedure CMFocusChanged(var Message: TCMFocusChanged); message CM_FOCUSCHANGED;
procedure CNCommand(var Message: TWMCommand); message CN_COMMAND;
procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;
protected
procedure CreateParams(var Params: TCreateParams); override;
procedure CreateWnd; override;
procedure SetButtonStyle(ADefault: Boolean); virtual;
public
constructor Create(AOwner: TComponent); override;
function UseRightToLeftAlignment: Boolean; override;
published
property Link: string read FLink write SetLink;
property Caption;
property DragCursor;
property DragKind;
property DragMode;
property Enabled;
property Font;
property PopupMenu;
property ShowHint;
property TabOrder;
property Visible;
property OnDragDrop;
property OnDragOver;
property OnEndDock;
property OnEndDrag;
property OnEnter;
property OnExit;
property OnKeyDown;
property OnKeyPress;
property OnKeyUp;
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
property OnStartDock;
property OnStartDrag;
end;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('Standard', [TLinkButton]);
end;
{ TLinkButton }
procedure TLinkButton.btnclick(Sender: TObject);
begin
ShellExecute(Handle,'open',PChar(Link),nil,nil,SW_RESTORE);
end;
procedure TLinkButton.SetLink(const Value: string);
var
L: Integer;
begin
L := Length(Value);
if (L > 1) and IsPathDelimiter(Value, L)
and not IsDelimiter(':', Value, L - 1) then Dec(L);
FLink := Copy(Value, 1, L);
end;
constructor TLinkButton.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
onclick := btnclick;
ControlStyle := [csSetCaption, csOpaque, csDoubleClicks];
Width := 75;
Height := 25;
TabStop := True;
end;
function TLinkButton.UseRightToLeftAlignment: Boolean;
begin
Result := False;
end;
procedure TLinkButton.SetButtonStyle(ADefault: Boolean);
const
BS_MASK = $000F;
var
Style: Word;
begin
if HandleAllocated then
begin
if ADefault then Style := BS_DEFPUSHBUTTON else Style := BS_PUSHBUTTON;
if GetWindowLong(Handle, GWL_STYLE) and BS_MASK <> Style then
SendMessage(Handle, BM_SETSTYLE, Style, 1);
end;
end;
procedure TLinkButton.CreateParams(var Params: TCreateParams);
const
ButtonStyles: array[Boolean] of DWORD = (BS_PUSHBUTTON, BS_DEFPUSHBUTTON);
begin
inherited CreateParams(Params);
CreateSubClass(Params, 'BUTTON');
Params.Style := Params.Style or ButtonStyles[FDefault];
end;
procedure TLinkButton.CreateWnd;
begin
inherited CreateWnd;
FActive := FDefault;
end;
procedure TLinkButton.CNCommand(var Message: TWMCommand);
begin
if Message.NotifyCode = BN_CLICKED then Click;
end;
procedure TLinkButton.CMDialogKey(var Message: TCMDialogKey);
begin
with Message do
if (((CharCode = VK_RETURN) and FActive) or
((CharCode = VK_ESCAPE) and FCancel)) and
(KeyDataToShiftState(Message.KeyData) = []) and CanFocus then
begin
Click;
Result := 1;
end else
inherited;
end;
procedure TLinkButton.CMDialogChar(var Message: TCMDialogChar);
begin
with Message do
if IsAccel(CharCode, Caption) and CanFocus then
begin
Click;
Result := 1;
end else
inherited;
end;
procedure TLinkButton.CMFocusChanged(var Message: TCMFocusChanged);
begin
with Message do
if Sender is TButton then
FActive := Sender = Self
else
FActive := FDefault;
SetButtonStyle(FActive);
inherited;
end;
procedure TLinkButton.WMEraseBkgnd(var Message: TWMEraseBkgnd);
begin
DefaultHandler(Message);
end;
end.

Здравствуйте, ubyou!
Привожу минимальный пример, который уже решает поставленную задачу

interface uses ....,Buttons, ShellAPI,....; //Эти юниты нам точно нужны Type { THyperLinkSpeedButton }//Объявление класса. Вообще то правильнее было бы наследоваться от TCustomSpeedButton. Но в условии попросили от TSpeedButton THyperLinkSpeedButton = class(TSpeedButton) private FWebLink:string; function GetWebLink: string; procedure SetWebLink(const AValue: string); public procedure Click; override; //Перекрываем метод, что бы ловить клики constructor Create(AOwner: TComponent); override;//перекрываем конструктор, что бы установить новые свойства. published property weblink:string read GetWebLink write SetWebLink;//наше новое свойство end; procedure Register; implementation procedure Register; begin RegisterComponents('Standard', [THyperLinkSpeedButton]); end; //реализация новых методов. { THyperLinkSpeedButton } //эти два метода реализованы в демонстрационных целях. Можно например по обновлению линка, обновлять хинт. Мало чего. //этот будет вызываться тогда, когда кто то запросит это свойство. Можем и модифицировать. function THyperLinkSpeedButton.GetWebLink: string; begin Result:=FWebLink; end; //этот метод вызывается, когда происходит установка свойства. //например можно сделать автоматическую прибавку http:// в начале или контроль правильности... procedure THyperLinkSpeedButton.SetWebLink(const AValue: string); begin FWebLink:=AValue; end; //собственно обрабатываем клик procedure THyperLinkSpeedButton.Click; begin if FWebLink <> '' then ShellExecute(handle,'open',PChar(FWebLink),nil,nil,SW_SHOW); inherited Click; //принято в переопределённых методах вызывать метод предка. Мало чего он там делает. // Иногда этого можно не делать, но надо быть точно уверенным, что там всё будет хорошо. end; //Что тут можно сделать - у меня не хватает фантазии. Ну например синий шрифт. //Важно то, что эти свойста будут установлены для компонента по умолчанию (точнее при создании) constructor Create(AOwner: TComponent); begin Font.color := clBlue; end; end.

Мини-форум вопроса

Чтобы оставлять сообщения в мини-форумах, Вы должны авторизироваться на сайте.

Экспертная система Delphi.int.ru

Сообщество программистов
Общение, помощь, обмен опытом

Delphi.int.ru Expert

Другие разделы портала

Переход к вопросу:

Статистика за сегодня:

Лучшие эксперты

Вопрос # 2 357

Мини-форум вопроса

Экспертная система Delphi.int.ru

Сообщество программистовОбщение, помощь, обмен опытом

Delphi.int.ru Expert

Другие разделы портала

Переход к вопросу:

Статистика за сегодня:

Лучшие эксперты

Вопрос # 2 357

Мини-форум вопроса

Сообщество программистов
Общение, помощь, обмен опытом