如何在TRichEdit中自动将邮箱地址转为可交互超链接？

TRichEdit自带EnableURLs和ShowURLHint属性，其中EnableURLs可自动将http://www.example.com这类URL转换为超链接。我尝试通过代码给邮箱地址实现同样功能，但目前仅能实现视觉上的超链接效果（蓝色下划线），无法实现完整的超链接交互：包括鼠标悬停显示crHandPoint光标、点击触发对应事件。

我的当前代码如下：

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;
    Label1: TLabel;
    procedure RichEdit1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

uses
  System.RegularExpressions;

procedure DetectAndLinkifyEmailsAndURLs(RichEdit: Vcl.ComCtrls.TRichEdit);
var
  Match: System.RegularExpressions.TMatch;
  EmailPattern, URLPattern: string;
  LineIndex, LineStart, StartPos, SelLength: Integer;
  LineText: string;
  PrevSelStart, PrevSelLength: Integer;
begin
  EmailPattern := '\b[A-Z0-9._%+-]+@[A-Z0-9.-]+\.[A-Z]{2,}\b';
  URLPattern := '\b(http|https)://[^\s]+';

  // Disable redraw to avoid flicker
  SendMessage(RichEdit.Handle, WM_SETREDRAW, WPARAM(False), 0);

  try
    // Save user selection
    PrevSelStart := RichEdit.SelStart;
    PrevSelLength := RichEdit.SelLength;

    // Reset all formatting to default for the entire text
    RichEdit.SelectAll;
    RichEdit.SelAttributes.Color := Vcl.Graphics.clWindowText;
    RichEdit.SelAttributes.Style := [];

    // Process line by line
    for LineIndex := 0 to RichEdit.Lines.Count - 1 do
    begin
      LineText := RichEdit.Lines[LineIndex];
      LineStart := RichEdit.Perform(EM_LINEINDEX, LineIndex, 0); // Get line start position

      // Format email addresses in the line
      Match := System.RegularExpressions.TRegEx.Match(LineText, EmailPattern, [System.RegularExpressions.roIgnoreCase]);
      while Match.Success do
      begin
        StartPos := LineStart + Match.Index - 1;
        SelLength := Match.Length;

        RichEdit.SelStart := StartPos;
        RichEdit.SelLength := SelLength;
        RichEdit.SelAttributes.Color := Vcl.Graphics.clBlue;
        RichEdit.SelAttributes.Style := [Vcl.Graphics.fsUnderline];

        Match := Match.NextMatch;
      end;

      // Format URLs in the line
      Match := System.RegularExpressions.TRegEx.Match(LineText, URLPattern, [System.RegularExpressions.roIgnoreCase]);
      while Match.Success do
      begin
        StartPos := LineStart + Match.Index - 1;
        SelLength := Match.Length;

        RichEdit.SelStart := StartPos;
        RichEdit.SelLength := SelLength;
        RichEdit.SelAttributes.Color := Vcl.Graphics.clBlue;
        RichEdit.SelAttributes.Style := [Vcl.Graphics.fsUnderline];

        Match := Match.NextMatch;
      end;
    end;

    // Restore user selection
    RichEdit.SelStart := PrevSelStart;
    RichEdit.SelLength := PrevSelLength;

    // Ensure the current selection uses default formatting
    if (PrevSelStart >= 0) and (PrevSelLength = 0) then
    begin
      RichEdit.SelAttributes.Color := Vcl.Graphics.clWindowText;
      RichEdit.SelAttributes.Style := [];
    end;
  finally
    // Re-enable redraw
    SendMessage(RichEdit.Handle, WM_SETREDRAW, WPARAM(True), 0);
    RichEdit.Invalidate; // Refresh to reflect changes
  end;
end;

procedure TForm1.RichEdit1Click(Sender: TObject);
begin
  DetectAndLinkifyEmailsAndURLs(RichEdit1);
end;

end.

解决方案 #

要实现完整的邮箱超链接功能，需要从三个核心维度修改：标记文本为真正的超链接、处理鼠标光标切换、响应点击事件。

1. 标记邮箱为可交互超链接 #

原代码仅修改了文本样式，没有将邮箱标记为TRichEdit认可的超链接。需要通过EM_SETCHARFORMAT消息设置CFE_LINK标志，让控件识别这是可交互的超链接：

修改DetectAndLinkifyEmailsAndURLs过程中处理邮箱的代码块：

// Format email addresses in the line
Match := System.RegularExpressions.TRegEx.Match(LineText, EmailPattern, [System.RegularExpressions.roIgnoreCase]);
while Match.Success do
begin
  // 修正位置计算：LineStart是行起始索引，Match.Index是文本内索引，直接相加即可
  StartPos := LineStart + Match.Index;
  SelLength := Match.Length;

  RichEdit.SelStart := StartPos;
  RichEdit.SelLength := SelLength;
  
  // 设置视觉样式
  RichEdit.SelAttributes.Color := Vcl.Graphics.clBlue;
  RichEdit.SelAttributes.Style := [Vcl.Graphics.fsUnderline];
  
  // 标记为超链接
  var cf: TCharFormat2;
  ZeroMemory(@cf, SizeOf(cf));
  cf.cbSize := SizeOf(cf);
  cf.dwMask := CFM_LINK;
  cf.dwEffects := CFE_LINK;
  SendMessage(RichEdit.Handle, EM_SETCHARFORMAT, SCF_SELECTION, LPARAM(@cf));

  Match := Match.NextMatch;
end;

2. 实现鼠标光标切换 #

在Form类中添加消息处理逻辑，监听WM_SETCURSOR消息，判断鼠标是否在超链接上，自动切换为手型光标：

首先在Form的private区域添加声明：

private
  function IsOverLink(RichEdit: TRichEdit): Boolean;
  procedure WndProc(var Message: TMessage); override;

然后实现这两个方法：

function TForm1.IsOverLink(RichEdit: TRichEdit): Boolean;
var
  Pos: TPoint;
  CharPos: Integer;
  cf: TCharFormat2;
begin
  Result := False;
  GetCursorPos(Pos);
  Pos := RichEdit.ScreenToClient(Pos);
  
  // 获取鼠标所在的字符位置
  CharPos := RichEdit.Perform(EM_CHARFROMPOS, 0, LPARAM(@Pos));
  if CharPos = -1 then Exit;
  
  // 检查该字符是否是超链接
  ZeroMemory(@cf, SizeOf(cf));
  cf.cbSize := SizeOf(cf);
  cf.dwMask := CFM_LINK;
  RichEdit.SelStart := CharPos;
  RichEdit.SelLength := 1;
  SendMessage(RichEdit.Handle, EM_GETCHARFORMAT, SCF_SELECTION, LPARAM(@cf));
  
  Result := (cf.dwEffects and CFE_LINK) <> 0;
end;

procedure TForm1.WndProc(var Message: TMessage);
begin
  inherited;
  if (Message.Msg = WM_SETCURSOR) and (HWND(Message.WParam) = RichEdit1.Handle) then
  begin
    if IsOverLink(RichEdit1) then
    begin
      SetCursor(Screen.Cursors[crHandPoint]);
      Message.Result := 1;
    end;
  end;
end;

3. 响应超链接点击事件 #

修改RichEdit1Click事件，获取点击的邮箱地址并触发自定义逻辑（比如打开系统默认邮箱客户端）：

procedure TForm1.RichEdit1Click(Sender: TObject);
var
  SelStart, SelLength: Integer;
  LinkText: string;
  cf: TCharFormat2;
begin
  // 先执行原有的格式化逻辑
  DetectAndLinkifyEmailsAndURLs(RichEdit1);
  
  // 检查点击位置是否是超链接
  ZeroMemory(@cf, SizeOf(cf));
  cf.cbSize := SizeOf(cf);
  cf.dwMask := CFM_LINK;
  SendMessage(RichEdit1.Handle, EM_GETCHARFORMAT, SCF_SELECTION, LPARAM(@cf));
  
  if (cf.dwEffects and CFE_LINK) <> 0 then
  begin
    // 获取整个超链接文本范围
    SelStart := RichEdit1.SelStart;
    SelLength := 0;
    
    // 向左查找超链接起始位置
    while SelStart > 0 do
    begin
      RichEdit1.SelStart := SelStart - 1;
      RichEdit1.SelLength := 1;
      SendMessage(RichEdit1.Handle, EM_GETCHARFORMAT, SCF_SELECTION, LPARAM(@cf));
      if (cf.dwEffects and CFE_LINK) = 0 then Break;
      Dec(SelStart);
      Inc(SelLength);
    end;
    
    // 向右查找超链接结束位置
    while SelStart + SelLength < RichEdit1.GetTextLen do
    begin
      RichEdit1.SelStart := SelStart + SelLength;
      RichEdit1.SelLength := 1;
      SendMessage(RichEdit1.Handle, EM_GETCHARFORMAT, SCF_SELECTION, LPARAM(@cf));
      if (cf.dwEffects and CFE_LINK) = 0 then Break;
      Inc(SelLength);
    end;
    
    // 获取超链接文本并触发逻辑
    RichEdit1.SelStart := SelStart;
    RichEdit1.SelLength := SelLength;
    LinkText := RichEdit1.SelText;
    
    // 打开系统默认邮箱客户端
    if Pos('@', LinkText) > 0 then
    begin
      ShellExecute(Handle, 'open', PChar('mailto:' + LinkText), nil, nil, SW_SHOWNORMAL);
    end;
  end;
end;

最终效果 #

修改完成后，邮箱地址会具备完整的超链接能力：

• 保持蓝色下划线的视觉样式
• 鼠标悬停时自动切换为手型光标
• 点击时自动打开系统默认邮箱客户端（或执行你自定义的处理逻辑）

内容的提问来源于stack exchange，提问作者user1580348