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

Question

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

但我想在不以www开头的字符串上放置链接.示例:" 下载 ".

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_LBUTTONDOWN then
        begin
          SetLength(str, p.chrg.cpMax - p.chrg.cpMin);
          tr.chrg := p.chrg;
          tr.lpstrText := PChar(strURL);
          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友好名称超链接

在RichEdit中,超链接字段实体由字符格式化效果表示,与用于构造数学对象的分隔符形成对比.因此,这些超链接不能嵌套,尽管在RichEdit 5.0及更高版本中它们可以彼此相邻.整个超链接具有字符格式的效果CFE_LINK和CFE_LINKPROTECTED,而autoURLs只拥有CFE_LINK属性.将CFE_LINKPROTECTED包括对于前者,这样的autoURL扫描仪跳过友好名称的链接.指令部分,即URL,也具有CFE_HIDDEN属性,因为它不应该被显示.URL本身用ASCII双引号括起来,前面是字符串“HYPERLINK “.由于CFE_HIDDEN在友好名称超链接中起着不可或缺的作用,因此不能在名称中使用它.

例如,在使用RichEdit的写字板中,名为MSN的超链接将具有纯文本

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

整个链路必须CFE_LINK和CFE_LINKPROTECTED字符格式属性和所有,但MSN将有CFE_HIDDEN属性.

这可以在代码中轻松模拟:

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;