在RichEdit中插入URL链接

unit Unit1;
interface
uses
 Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
 Dialogs, StdCtrls, ComCtrls, RichEdit, ShellAPI;
type
 TForm1 = class(TForm)
   redt1: TRichEdit;
   btn1: TButton;
   procedure btn1Click(Sender: TObject);
 private
   { Private declarations }
   procedure WndProc(var Msg: TMessage); override;
 public
   { Public declarations }
 end;
var
 Form1: TForm1;
implementation
{$R *.dfm}
function EditStreamInCallback(dwCookie: Longint; pbBuff: PByte;
 cb: Longint; var pcb: Longint): Longint; stdcall;
 // by P. Below
var
 theStream: TStream;
 dataAvail: LongInt;
begin
 theStream := TStream(dwCookie);
 with theStream do
 begin
   dataAvail := Size - Position;
   Result := 0;
   if dataAvail <= cb then
   begin
     pcb := read(pbBuff^, dataAvail);
     if pcb <> dataAvail then
       Result := UINT(E_FAIL);
   end
   else
   begin
     pcb := read(pbBuff^, cb);
     if pcb <> cb then
       Result := UINT(E_FAIL);
   end;
 end;
end;
// Insert Stream into RichEdit
procedure PutRTFSelection(RichEdit: TRichEdit; RTFText: ansistring);
 // by P. Below
var
 sourcestream: TStream;
 EditStream: TEditStream;
begin
 sourcestream := TStringStream.Create(RTFText);
 sourcestream.Position := 0;
 with EditStream do
 begin
   dwCookie := Longint(SourceStream);
   dwError := 0;
   pfnCallback := EditStreamInCallBack;
 end;
 RichEdit.Perform(EM_STREAMIN, SF_RTF or SFF_SELECTION, Longint(@EditStream));
 form1.Caption := SysErrorMessage(GetLastError);
 sourcestream.Free;
end;
procedure TForm1.btn1Click(Sender: TObject);
var
 mask : Word;
begin
 redt1.Perform(EM_AUTOURLDETECT, 1, 0);
 mask := SendMessage(redt1.Handle, EM_GETEVENTMASK, 0, 0);
 redt1.Perform( EM_SETEVENTMASK, 0, mask or ENM_LINK);
 PutRTFSelection(redt1, '{\field{\*\fldinst{HYPERLINK " }{\\fldrslt{\\cf1\\ul" http://www.test.com"}}{\fldrslt{\cf1\ul Click me}}}');
end;
procedure TForm1.WndProc(var Msg: TMessage);
var
 p: TENLink;
 strURL: string;
begin
 if (msg.Msg = WM_NOTIFY) then
 begin
   if (PNMHDR(Msg.lParam).code = EN_LINK) then
   begin
     p := TENLink(Pointer(TWMNotify(Msg).NMHdr)^);
     if (p.Msg = WM_LBUTTONDOWN) then
     begin
       redt1.Perform(EM_EXSETSEL, 0, Longint(@(p.chrg)));
       strURL := redt1.SelText;
       ShellExecute(Handle, 'open', PChar(strURL), 0, 0, SW_SHOWNORMAL);
     end
   end
 end;
 inherited;
end;
end.