|
Вопрос # 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 (статус: Посетитель)
Вопрос отправлен: 28 января 2009, 01:05
Состояние вопроса: открыт, ответов: 1.
|
Ответ #1. Отвечает эксперт: Вадим К
Здравствуйте, 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.
Осталось оформить всё это в виде красивого юнита, что бы глаз радовал. Поставленную задачу компонент точно выполняет. Код примитивный...
 |
Ответ отправил: Вадим К (статус: Академик)
Время отправки: 28 января 2009, 03:34
Оценка за ответ: 5
Комментарий к оценке: Спасибо! Очень оперативно...Без вашей помощи ни как не получается...
|
Мини-форум вопроса
Всего сообщений: 5; последнее сообщение — 29 января 2009, 02:07; участников в обсуждении: 2.
|
ubyou (статус: Посетитель), 28 января 2009, 21:12 [#1]:
Чего то не добавилось нового свойства для в вода линки в инспектор объектов,свойства (( Что то наверное не так???
|
|
Вадим К (статус: Академик), 29 января 2009, 00:23 [#2]:
Вообще то должно появиться. Свойства, объявленные в published должны появляться. Конечно, может быть, что объявили в public разделе...
посмотрите внимательнее, должно быть свойство weblink.
Галочка "подтверждения прочтения" - вселенское зло.
|
|
ubyou (статус: Посетитель), 29 января 2009, 00:35 [#3]:
Нет, нету этого weblink в свойствах(
|
|
ubyou (статус: Посетитель), 29 января 2009, 01:16 [#4]:
ShellExecute(handle,'open',PChar(FWebLink),nil,nil,SW_SHOW);
не получается скомпилить ругается на handle...говорит что Undeclared Identifer
|
|
Вадим К (статус: Академик), 29 января 2009, 02:07 [#5]:
м, точно. нету у него этого свойства. Попробуйте передать туда 0. Должно работать. Просто я тестирую под Лазарусом (Линукс). А там такой функции нет... ну не может её там быть...
Галочка "подтверждения прочтения" - вселенское зло.
|
Чтобы оставлять сообщения в мини-форумах, Вы должны авторизироваться на сайте.
|