导航

Delphi 关于RichEdit URL 颜色相关总结

Posted on 2022-04-27 10:35  wissly  阅读(340)  评论(0)  编辑  收藏  举报

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

 1 procedure TForm1.Button1Click(Sender: TObject);
 2 var
 3   sNickName, sstr: string;
 4 begin
 5   sstr := '改变颜色的字符串-----------------!';
 6   sNickName := '用户1：';
 7   richedit1.Lines.Add(sNickName + sstr);
 8 
 9   RichEdit1.SelStart := Length(RichEdit1.Text) - Length(sstr)-2;//(Length(sNickName)  + length(sstr)); //Length(sNickName);
10 
11   RichEdit1.SelLength := Length(sstr);
12   richedit1.SelAttributes.Color := clRed;
13 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;




 1 procedure TForm1.InitRichEditURLDetection(re: TRichEdit);
 2 var
 3   mask: Word;
 4 begin
 5   mask := SendMessage(RE.Handle,EM_GETEVENTMASK, 0,0);
 6   SendMessage(RE.Handle, EM_SETEVENTMASK,0, mask or ENM_LINK);
 7   SendMessage(RE.Handle,EM_AUTOURLDETECT, Integer(True), 0);
 8 end;
 9 
10 procedure TForm1.wndproc(var message: tmessage);
11 var
12   p: tenlink;
13   strurl: string;
14 begin
15   if (message.msg = wm_notify) then
16   begin
17     if (pnmhdr(message.lparam).code = en_link) then
18     begin
19       p := tenlink(pointer(twmnotify(message).nmhdr)^);
20       if (p.msg = wm_lbuttondown) then
21       begin
22         sendmessage(MyRichEdit.handle, em_exsetsel, 0, longint(@(p.chrg)));
23         strurl := MyRichEdit.seltext;
24         shellexecute(handle, 'open', pchar(strurl), 0, 0, sw_shownormal);
25       end;
26     end ;
27   end;
28   inherited;
29 end;