Создаем гипер-ссылку в Delphi

29.11.2011
Простой способ сделать ссылку: 
Разместить на форме TLabel и на событие OnClick вызвать ShellExecute, а в uses формы добавить ShellAPI.

Пример:

Uses ShellAPI;

procedure TForm1.Label1Click(Sender: TObject);
begin
  ShellExecute(handle, 'open', 'http://oddler.ru/', nil, nil, SW_SHOW);
end;

Пара слов о параметрах:

  • handle - это дескриптор формы (аналогично Form1.handle)
  • open - тип действия. Нам надо открыть ссылку (в общем виде – открыть файл).
  • http:// oddler.ru/ - ссылка (имя файла), которую надо открыть.
  • nil - здесь никаких дополнительных параметров открытия файла не должно быть, поэтому nil.
  • nil - директория по умолчанию нас так же не интересует.
  • SW_SHOW - активирует окно и отображает его с текущими размерами и положением.

Об остальных режимах можно узнать в хелпе (о функции ShellExecute).

 

Желательно сделать визуальное оформление похожим на ссылки в браузере:

implementation
const

  link = clBlue; //цвет ссылки
  alink = clRed; //цвет ссылки в момент нажатия
  vlink = clPurple; // цвет посещеной ссылки
{$R *.DFM}
...

Теперь в обработчике события формы OnCreate надо написать:

procedure TForm1.FormCreate(Sender: TObject);
begin
  Label1.font.Color := link;
end;

В обработчике события метки OnMouseDown мы напишем:

procedure TForm1.Label1MouseDown(Sender: TObject;
  Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
  Label1.Font.Color := alink;
end;

А в обработчике события OnMouseUp нашей метки мы напишем:

procedure TForm1.Label1MouseUp(Sender: TObject;
  Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
  Label1.Font.Color := vlink;
end;

 

Если требуется не одна ссылка, то логичнее использовать компонент, вот листинг готового решения: (сохранить надо в файле Link.pas)

unit Link;

interface

uses
  Windows, SysUtils, Classes, Forms, StdCtrls, ShellAPI, Menus,
  Controls, Graphics;

type

  TLink = class(TLabel)

  private
    //поле для хранения URL
    FURL: string;

    // поля для хранения настроек цветов ссылки
    FlinkColor, FAlinkColor, FVlinkColor: TColor;

  protected

  public
    //конструктор и деструктор
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    //события, которые нам надо переопределить

    procedure Click; override;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
      override;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
      override;

  published

    //свойства, которые будут видны в Object Inspector
    property URL: string read FURL write FURL;
    property LinkColor: TColor read FLinkColor write FLinkColor default clBlue;
    property ALinkColor: TColor read FALinkColor write FALinkColor default clRed;
    property VLinkColor: TColor read FVLinkColor write FVLinkColor default clPurple;

  end;


procedure Register;

implementation

constructor TLink.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  //устанавливаем цвета

  FALinkColor := clRed;
  FLinkColor := clBlue;
  FVLinkColor := clPurple;
  //сделаем метку синей и подчеркнутой
  with Font do
  begin
    Color := FLinkColor;
    Style := [fsUnderline];
  end;

end;

procedure TLink.Click;
begin
  inherited Click;
  //если поле URL заполнено, то перейдем по ссылке
  if FURL <> '' then

    ShellExecute(GetDesktopWindow(), 'open', PChar(FURl), nil, nil, SW_SHOW);
end;

procedure TLink.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y:
  Integer);
begin
  if Button = mbLeft then

  begin
    FLinkColor := Font.Color;
    Font.Color := FALinkColor;
  end;
  inherited;
end;

procedure TLink.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y:
  Integer);
begin
  if Button = mbLeft then

    Font.Color := FVLinkColor;
  inherited;
end;

destructor TLink.Destroy;
begin
  //уничтожим компонент
  inherited;

end;

procedure Register;
begin
  //надо, чтобы компонент появился в палитре
  RegisterComponents('Oddler', [TLink]);
end;

end.

Категории: Delphi
Яндекс.Метрика