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

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

Логин:
Пароль:
Регистрация | Забыли пароль?

Delphi.int.ru Expert

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

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

#   

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


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

Подробнее »



Вопрос # 2 357

/ вопрос открыт /

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

Приложение:
  1. unit LinkButton;
  2.  
  3. interface
  4.  
  5. uses
  6. Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  7. StdCtrls, shellapi;
  8.  
  9. type
  10. TLinkButton = class(TButtonControl)
  11. private
  12. FDefault: Boolean;
  13. FCancel: Boolean;
  14. FActive: Boolean;
  15. FLink: string;
  16. procedure SetLink(const Value: string);
  17. procedure btnclick(Sender: TObject);
  18. procedure CMDialogKey(var Message: TCMDialogKey); message CM_DIALOGKEY;
  19. procedure CMDialogChar(var Message: TCMDialogChar); message CM_DIALOGCHAR;
  20. procedure CMFocusChanged(var Message: TCMFocusChanged); message CM_FOCUSCHANGED;
  21. procedure CNCommand(var Message: TWMCommand); message CN_COMMAND;
  22. procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;
  23. protected
  24. procedure CreateParams(var Params: TCreateParams); override;
  25. procedure CreateWnd; override;
  26. procedure SetButtonStyle(ADefault: Boolean); virtual;
  27. public
  28. constructor Create(AOwner: TComponent); override;
  29. function UseRightToLeftAlignment: Boolean; override;
  30. published
  31. property Link: string read FLink write SetLink;
  32. property Caption;
  33. property DragCursor;
  34. property DragKind;
  35. property DragMode;
  36. property Enabled;
  37. property Font;
  38. property PopupMenu;
  39. property ShowHint;
  40. property TabOrder;
  41. property Visible;
  42. property OnDragDrop;
  43. property OnDragOver;
  44. property OnEndDock;
  45. property OnEndDrag;
  46. property OnEnter;
  47. property OnExit;
  48. property OnKeyDown;
  49. property OnKeyPress;
  50. property OnKeyUp;
  51. property OnMouseDown;
  52. property OnMouseMove;
  53. property OnMouseUp;
  54. property OnStartDock;
  55. property OnStartDrag;
  56. end;
  57.  
  58. procedure Register;
  59.  
  60. implementation
  61.  
  62. procedure Register;
  63. begin
  64. RegisterComponents('Standard', [TLinkButton]);
  65. end;
  66.  
  67. { TLinkButton }
  68.  
  69. procedure TLinkButton.btnclick(Sender: TObject);
  70. begin
  71. ShellExecute(Handle,'open',PChar(Link),nil,nil,SW_RESTORE);
  72. end;
  73.  
  74. procedure TLinkButton.SetLink(const Value: string);
  75. var
  76. L: Integer;
  77. begin
  78. L := Length(Value);
  79. if (L > 1) and IsPathDelimiter(Value, L)
  80. and not IsDelimiter(':', Value, L - 1) then Dec(L);
  81. FLink := Copy(Value, 1, L);
  82. end;
  83.  
  84. constructor TLinkButton.Create(AOwner: TComponent);
  85. begin
  86. inherited Create(AOwner);
  87. onclick := btnclick;
  88. ControlStyle := [csSetCaption, csOpaque, csDoubleClicks];
  89. Width := 75;
  90. Height := 25;
  91. TabStop := True;
  92. end;
  93.  
  94. function TLinkButton.UseRightToLeftAlignment: Boolean;
  95. begin
  96. Result := False;
  97. end;
  98.  
  99. procedure TLinkButton.SetButtonStyle(ADefault: Boolean);
  100. const
  101. BS_MASK = $000F;
  102. var
  103. Style: Word;
  104. begin
  105. if HandleAllocated then
  106. begin
  107. if ADefault then Style := BS_DEFPUSHBUTTON else Style := BS_PUSHBUTTON;
  108. if GetWindowLong(Handle, GWL_STYLE) and BS_MASK <> Style then
  109. SendMessage(Handle, BM_SETSTYLE, Style, 1);
  110. end;
  111. end;
  112.  
  113. procedure TLinkButton.CreateParams(var Params: TCreateParams);
  114. const
  115. ButtonStyles: array[Boolean] of DWORD = (BS_PUSHBUTTON, BS_DEFPUSHBUTTON);
  116. begin
  117. inherited CreateParams(Params);
  118. CreateSubClass(Params, 'BUTTON');
  119. Params.Style := Params.Style or ButtonStyles[FDefault];
  120. end;
  121.  
  122. procedure TLinkButton.CreateWnd;
  123. begin
  124. inherited CreateWnd;
  125. FActive := FDefault;
  126. end;
  127.  
  128. procedure TLinkButton.CNCommand(var Message: TWMCommand);
  129. begin
  130. if Message.NotifyCode = BN_CLICKED then Click;
  131. end;
  132.  
  133. procedure TLinkButton.CMDialogKey(var Message: TCMDialogKey);
  134. begin
  135. with Message do
  136. if (((CharCode = VK_RETURN) and FActive) or
  137. ((CharCode = VK_ESCAPE) and FCancel)) and
  138. (KeyDataToShiftState(Message.KeyData) = []) and CanFocus then
  139. begin
  140. Click;
  141. Result := 1;
  142. end else
  143. inherited;
  144. end;
  145.  
  146. procedure TLinkButton.CMDialogChar(var Message: TCMDialogChar);
  147. begin
  148. with Message do
  149. if IsAccel(CharCode, Caption) and CanFocus then
  150. begin
  151. Click;
  152. Result := 1;
  153. end else
  154. inherited;
  155. end;
  156.  
  157. procedure TLinkButton.CMFocusChanged(var Message: TCMFocusChanged);
  158. begin
  159. with Message do
  160. if Sender is TButton then
  161. FActive := Sender = Self
  162. else
  163. FActive := FDefault;
  164. SetButtonStyle(FActive);
  165. inherited;
  166. end;
  167.  
  168. procedure TLinkButton.WMEraseBkgnd(var Message: TWMEraseBkgnd);
  169. begin
  170. DefaultHandler(Message);
  171. end;
  172.  
  173. end.


ubyou Вопрос ожидает решения (принимаются ответы, доступен мини-форум)

Вопрос задал: 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

ubyou (статус: Посетитель), 28 января 2009, 21:12 [#1]:

Чего то не добавилось нового свойства для в вода линки в инспектор объектов,свойства (( Что то наверное не так???
Вадим К

Вадим К (статус: Академик), 29 января 2009, 00:23 [#2]:

Вообще то должно появиться. Свойства, объявленные в published должны появляться. Конечно, может быть, что объявили в public разделе...
посмотрите внимательнее, должно быть свойство weblink.
Галочка "подтверждения прочтения" - вселенское зло.
ubyou

ubyou (статус: Посетитель), 29 января 2009, 00:35 [#3]:

Нет, нету этого weblink в свойствах(
ubyou

ubyou (статус: Посетитель), 29 января 2009, 01:16 [#4]:

ShellExecute(handle,'open',PChar(FWebLink),nil,nil,SW_SHOW);

не получается скомпилить ругается на handle...говорит что Undeclared Identifer
Вадим К

Вадим К (статус: Академик), 29 января 2009, 02:07 [#5]:

м, точно. нету у него этого свойства. Попробуйте передать туда 0. Должно работать. Просто я тестирую под Лазарусом (Линукс). А там такой функции нет... ну не может её там быть...
Галочка "подтверждения прочтения" - вселенское зло.

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

Версия движка: 2.6+ (26.01.2011)
Текущее время: 22 февраля 2025, 11:45
Выполнено за 0.03 сек.