Delphi 关于RichEdit URL 颜色相关总结

一、代码改变字体大小和颜色

procedure TForm1.Button1Click(Sender: TObject);
var
  sNickName, sstr: string;
begin
  sstr := '改变颜色的字符串-----------------!';
  sNickName := '用户1：';
  richedit1.Lines.Add(sNickName + sstr);

  RichEdit1.SelStart := Length(RichEdit1.Text) - Length(sstr)-2;//(Length(sNickName)  + length(sstr)); //Length(sNickName);

  RichEdit1.SelLength := Length(sstr);

  richedit1.SelAttributes.Color := clRed;

end;

二、增加URL超级链接检测及跳转

方法一

procedure TForm.MyRichEditMouseMove(Sender: TObject;Shift: TShiftState; X, Y: Integer);
var 
  I,L: Integer;
  S,T: string;
  vRect: TRect;
begin
  sPubURL := '';
  vRect.Left := X;
  vRect.Top := Y;
  X := TRichEdit(Sender).Perform(EM_CHARFROMPOS,0,Longint(@vRect.TopLeft)) and $0000FFFF + 1;
  S := TRichEdit(Sender).Text;
  L := Length(S);
  if (X > L) or (X < 0) or (not (S[X] in [#33..#172])) then
  begin
    MyRichEdit.Cursor := crDefault;
    Exit;
  end;
  T := S[X];
  for I := X - 1 downto 1 do
  if S[I] in [#33..#172] then T := S[I] + T else Break;
  for I := X + 1 to L do
  if S[I] in [#33..#172] then T := T + S[I] else Break;
  I := Pos('MAILTO:', UpperCase(T));
  if I <= 0 then I := Pos('HTTPS://', UpperCase(T));  
  if I <= 0 then I := Pos('HTTP://', UpperCase(T));
  if I <= 0 then I := Pos('FTP://', UpperCase(T));
  if I <= 0 then I := Pos('WWW.', UpperCase(T));
  if I <> 1 then
  begin
    MyRichEdit.Cursor := crDefault;
    Exit;
  end;
  sPubURL := T;
  MyRichEdit.Cursor := crHandPoint;
end;

procedure TForm.MyRichEditMouseDown(Sender: TObject;Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
  if sPubURL <> '' then ShellExecute(Handle, 'open', PCharsPubURL nil, nil, SW_SHOW); 
end;

procedure TForm.MyRichEditChange(Sender: TObject);
var
  S: string;
  T: string;
  I, J, L: Integer;
  vSelStart: Integer;
  vSelLength: Integer;
begin
  TRichEdit(Sender).Perform(EM_HIDESELECTION, Longint(True), 0);
  S := TRichEdit(Sender).Text;
  L := Length(S);
  J := 1;
  vSelStart := TRichEdit(Sender).SelStart;
  vSelLength := TRichEdit(Sender).SelLength;
  TRichEdit(Sender).SelStart := 0;
  TRichEdit(Sender).SelLength := L;
  TRichEdit(Sender).SelAttributes.Color := clWindowText;
  TRichEdit(Sender).SelAttributes.Style := [];
  while J <= L do
  begin
    T := '';
    for I := J to L do
    if S[I] in [#33..#172] then T := T + S[I] else Break;
    if T <> '' then
    begin
      I := Pos('MAILTO:', UpperCase(T));
      if I <= 0 then I := Pos('HTTPS://', UpperCase(T));      
      if I <= 0 then I := Pos('HTTP://', UpperCase(T));
      if I <= 0 then I := Pos('FTP://', UpperCase(T));
      if I <= 0 then I := Pos('WWW.', UpperCase(T));
      if I = 1 then
      begin
        TRichEdit(Sender).SelStart := J - 1;
        TRichEdit(Sender).SelLength := Length(T);
        TRichEdit(Sender).SelAttributes.Color := clBlue;
        TRichEdit(Sender).SelAttributes.Style := [fsUnderline];
      end;
      Inc(J, Length(T));
    end;
    Inc(J);
  end;
  TRichEdit(Sender).SelStart := vSelStart;
  TRichEdit(Sender).SelLength := vSelLength;
  TRichEdit(Sender).Perform(EM_HIDESELECTION, Longint(False), 0);
end;

方法二

1、加载内容前调用 InitRichEditURLDetection
2、覆盖消息 procedure wndproc(var message : tmessage); override;

procedure TForm1.InitRichEditURLDetection(re: TRichEdit);
var
  mask: Word;
begin
  mask := SendMessage(RE.Handle,EM_GETEVENTMASK, 0,0);
  SendMessage(RE.Handle, EM_SETEVENTMASK,0, mask or ENM_LINK);
  SendMessage(RE.Handle,EM_AUTOURLDETECT, Integer(True), 0);
end;

procedure TForm1.wndproc(var message: tmessage);
var
  p: tenlink;
  strurl: string;
begin
  if (message.msg = wm_notify) then
  begin
    if (pnmhdr(message.lparam).code = en_link) then
    begin
      p := tenlink(pointer(twmnotify(message).nmhdr)^);
      if (p.msg = wm_lbuttondown) then
      begin
        sendmessage(MyRichEdit.handle, em_exsetsel, 0, longint(@(p.chrg)));
        strurl := MyRichEdit.seltext;
        shellexecute(handle, 'open', pchar(strurl), 0, 0, sw_shownormal);
      end;
    end ;
  end;
  inherited;
end;