html - 为 TRichEdit 添加真正的超链接支持

Question

我需要在 TRichEdit 中支持“友好名称超链接”，我找到的所有解决方案都基于自动 URL(EM_AUTOURLDETECT)，它通过检测用户输入的以 www(或 http)开头的字符串来工作。

但我想在不以 www 开头的字符串上放置链接。示例:' Download '.

Answer 1

您需要执行以下操作:

1. 向 RichEdit 发送 EM_SETEVENTMASK启用 ENM_LINK 标志的消息。在创建 RichEdit 后执行此操作一次，然后在每次 RichEdit 收到 CM_RECREATEWND 消息时再次执行此操作。

2. 选择您想要变成链接的文本。您可以使用 RichEdit 的 SelStart 和 SelLength 属性，或向 RichEdit 发送 EM_SETSEL或 EM_EXSETSEL信息。无论哪种方式，然后向 RichEdit 发送 EM_SETCHARFORMAT带有 CHARFORMAT2 的消息结构以对所选文本启用 CFE_LINK 效果。

3. 继承 RichEdit 的 WindowProc 属性来处理 CN_NOTIFY(EN_LINK)和 CM_RECREATEWND 消息。收到 EN_LINK 后，您可以使用 ShellExecute/Ex() 启动所需的 URL。

例如:

unit Unit1;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, Vcl.ComCtrls;

type
  TForm1 = class(TForm)
    RichEdit1: TRichEdit;
    Button1: TButton;
    procedure FormCreate(Sender: TObject);
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
    PrevRichEditWndProc: TWndMethod;
    procedure InsertHyperLink(const HyperlinkText: string);
    procedure SetRichEditMasks;
    procedure RichEditWndProc(var Message: TMessage);
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

uses
  Winapi.RichEdit, Winapi.ShellAPI;

procedure TForm1.FormCreate(Sender: TObject);
begin
  PrevRichEditWndProc := RichEdit1.WindowProc;
  RichEdit1.WindowProc := RichEditWndProc;

  SetRichEditMasks;

  RichEdit1.Text := 'Would you like to Download Now?';

  RichEdit1.SelStart := 18;
  RichEdit1.SelLength := 12;    
  InsertHyperLink('Download Now');
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  InsertHyperLink('Another Link');
end;

procedure TForm1.InsertHyperLink(const HyperlinkText: string);
var
  Fmt: CHARFORMAT2;
  StartPos: Integer;
begin
  StartPos := RichEdit1.SelStart;
  RichEdit1.SelText := HyperlinkText;

  RichEdit1.SelStart := StartPos;
  RichEdit1.SelLength := Length(HyperlinkText);

  FillChar(Fmt, SizeOf(Fmt), 0);
  Fmt.cbSize := SizeOf(Fmt);
  Fmt.dwMask := CFM_LINK;
  Fmt.dwEffects := CFE_LINK;

  SendMessage(RichEdit1.Handle, EM_SETCHARFORMAT, SCF_SELECTION, LPARAM(@Fmt));

  RichEdit1.SelStart := StartPos + Length(HyperlinkText);
  RichEdit1.SelLength := 0;
end;

procedure TForm1.SetRichEditMasks;
var
  Mask: DWORD;
begin
  Mask := SendMessage(RichEdit1.Handle, EM_GETEVENTMASK, 0, 0);
  SendMessage(RichEdit1.Handle, EM_SETEVENTMASK, 0, Mask or ENM_LINK);
  SendMessage(RichEdit1.Handle, EM_AUTOURLDETECT, 1, 0);
end;

procedure TForm1.RichEditWndProc(var Message: TMessage);
type
  PENLINK = ^ENLINK;
var
  tr: TEXTRANGE;
  str: string;
  p: PENLINK;
begin
  PrevRichEditWndProc(Message);

  case Message.Msg of
    CN_NOTIFY: begin
     if TWMNotify(Message).NMHdr.code = EN_LINK then
      begin
        P := PENLINK(Message.LParam);
        if p.msg = WM_LBUTTONUP then
        begin
          SetLength(str, p.chrg.cpMax - p.chrg.cpMin);
          tr.chrg := p.chrg;
          tr.lpstrText := PChar(str);
          SendMessage(RichEdit1.Handle, EM_GETTEXTRANGE, 0, LPARAM(@tr));

          if str = 'Download Now' then
          begin
            ShellExecute(Handle, nil, 'http://www.SomeSite.com/download', nil, nil, SW_SHOWDEFAULT);
          end
          else if str = 'Another Link' then
          begin
            // do something else
          end;
        end;
      end;
    end;

    CM_RECREATEWND: begin
      SetRichEditMasks;
    end;
  end;
end;

end.

---

更新:根据 MSDN:

RichEdit Friendly Name Hyperlinks

In RichEdit, the hyperlink field entity is represented by character formatting effects, as contrasted to delimiters which are used to structure math objects. As such, these hyperlinks cannot be nested, although in RichEdit 5.0 and later they can be adjacent to one another. The whole hyperlink has the character formatting effects of CFE_LINK and CFE_LINKPROTECTED, while autoURLs only have the CFE_LINK attribute. The CFE_LINKPROTECTED is included for the former so that the autoURL scanner skips over friendly name links. The instruction part, i.e., the URL, has the CFE_HIDDEN attribute as well, since it’s not supposed to be displayed. The URL itself is enclosed in ASCII double quotes and preceded by the string “HYPERLINK “. Since CFE_HIDDEN plays an integral role in friendly name hyperlinks, it cannot be used in the name.

For example, in WordPad, which uses RichEdit, a hyperlink with the name MSN would have the plain text

HYPERLINK “http://www.msn.com”MSN

The whole link would have CFE_LINK and CFE_LINKPROTECTED character formatting attributes and all but the MSN would have the CFE_HIDDEN attribute.

这可以很容易地用代码模拟:

procedure TForm1.FormCreate(Sender: TObject);
begin
  ...
  RichEdit1.Text := 'Would you like to Download Now?';

  RichEdit1.SelStart := 18;
  RichEdit1.SelLength := 12;    
  InsertHyperLink('Download Now', 'http://www.SomeSite.com/downloads');
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  InsertHyperLink('A Text Link');
end;

procedure TForm1.InsertHyperLink(const HyperlinkText: string; const HyperlinkURL: string = '');
var
  HyperlinkPrefix, FullHyperlink: string;
  Fmt: CHARFORMAT2;
  StartPos: Integer;
begin
  if HyperlinkURL <> '' then
  begin
    HyperlinkPrefix := Format('HYPERLINK "%s"', [HyperlinkURL]);
    FullHyperlink := HyperlinkPrefix + HyperlinkText;
  end else begin
    FullHyperlink := HyperlinkText;
  end;

  StartPos := RichEdit1.SelStart;
  RichEdit1.SelText := FullHyperlink;

  RichEdit1.SelStart := StartPos;
  RichEdit1.SelLength := Length(FullHyperlink);

  FillChar(Fmt, SizeOf(Fmt), 0);
  Fmt.cbSize := SizeOf(Fmt);
  Fmt.dwMask := CFM_LINK;
  Fmt.dwEffects := CFE_LINK;
  if HyperlinkURL <> '' then
  begin
    // per MSDN: "RichEdit doesn’t allow the CFE_LINKPROTECTED attribute to be
    // set directly by programs. Maybe it will allow it someday after enough
    // testing is completed to ensure that things cannot go awry"...
    //
    {
    Fmt.dwMask := Fmt.dwMask or CFM_LINKPROTECTED;
    Fmt.dwEffects := Fmt.dwEffects or CFE_LINKPROTECTED;
    }
  end;

  SendMessage(RichEdit1.Handle, EM_SETCHARFORMAT, SCF_SELECTION, LPARAM(@Fmt));

  if HyperlinkURL <> '' then
  begin
    RichEdit1.SelStart := StartPos;
    RichEdit1.SelLength := Length(HyperlinkPrefix);

    FillChar(Fmt, SizeOf(Fmt), 0);
    Fmt.cbSize := SizeOf(Fmt);
    Fmt.dwMask := CFM_HIDDEN;
    Fmt.dwEffects := CFE_HIDDEN;

    SendMessage(RichEdit1.Handle, EM_SETCHARFORMAT, SCF_SELECTION, LPARAM(@Fmt));
  end;

  RichEdit1.SelStart := StartPos + Length(FullHyperlink);
  RichEdit1.SelLength := 0;
end;

然后通过解析点击的超链接文本在EN_LINK通知中处理:

uses
  ..., System.StrUtils;

...

SendMessage(RichEdit1.Handle, EM_GETTEXTRANGE, 0, LPARAM(@tr));

// Per MSDN: "The ENLINK notification structure contains a CHARRANGE with
// the start and end character positions of the actual URL (IRI, file path
// name, email address, etc.) that typically appears in a browser URL
// window. This doesn’t include the “HYPERLINK ” string nor the quotes in
// the hidden part. For the MSN link above, it identifies only the
// http://www.msn.com characters in the backing store."
//
// However, without the CFM_LINKPROTECTED flag, the CHARRANGE will report
// the positions of the entire "HYPERLINK ..." string instead, so just strip
// off what is not needed...
//
if StartsText('HYPERLINK "', str) then
begin
  Delete(str, 1, 11);
  Delete(str, Pos('"', str), MaxInt);
end;

if (str is a URL) then begin
  ShellExecute(Handle, nil, PChar(str), nil, nil, SW_SHOWDEFAULT);
end
else begin
  // do something else
end;