Highlight Links in Memo

Unit HighlightURL_unit.pas

unit HighlightURL_unit;

interface

uses ComCtrls, Windows, Messages, RichEdit, Graphics, Controls;

procedure HighlightURL(const RichEdit : TRichEdit);
function GetURLUnderCursor(const RichEdit : TRichEdit) : string;
procedure UpdateWordUnderCursor(const RichEdit : TRichEdit);

implementation

function isValidChar(const c : char) : boolean;
const validChars = 'abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789$-_.+!*''(),{}|\^~[]`<>#%|<>;/?:@&=';
begin
  result := Pos(c, validChars) <> 0;
end;



procedure HighlightURL(const RichEdit : TRichEdit);
var sCopy : string;
    memoIndex : integer;
    s : string;
    urlPos : integer;
    j : integer;
    URL : string;

begin
  s := RichEdit.Lines.Text;
  sCopy := Copy(s, 0, length(s));
  memoIndex := 0;

  RichEdit.Tag := 1;
  RichEdit.Perform(Messages.WM_USER + 63, WPARAM(TRUE), LPARAM(FALSE));
  RichEdit.SelectAll;
  RichEdit.SelAttributes.Color := clBlack;
  RichEdit.SelAttributes.Style := [];

  urlPos := Pos('https://', sCopy);
  while urlPos <> 0 do begin
    sCopy := Copy(sCopy, urlPos, length(sCopy));
    memoIndex := memoIndex + urlPos;
    RichEdit.SelStart := memoIndex - 1;
    j := 1;
    URL := '';
    while isValidChar(sCopy[j]) do begin
      URL := URL + sCopy[j];
      j := j + 1;
    end;
    sCopy := copy(sCopy, j, length(sCopy));
    memoIndex := memoIndex + j - 2;
    RichEdit.SelLength := memoIndex - RichEdit.SelStart;
    RichEdit.SelAttributes.Color := clBlue;
    RichEdit.SelAttributes.Style := [fsUnderline];
    urlPos := Pos('https://', sCopy);
  end;
  RichEdit.SelStart := 0;
  RichEdit.Perform(Messages.WM_USER + 63, WPARAM(FALSE), LPARAM(FALSE));
  RichEdit.Tag := 0;
end;

function GetURLUnderCursor(const RichEdit : TRichEdit) : string;
var
  iWordStart, iWordEnd,
  iCharIndex, iLineIndex, iCharOffset: Integer;
  Pt: TPoint;
  mouse : TMouse;
begin
  Result := '';
  mouse := TMouse.Create();
  Pt := mouse.CursorPos;
  Pt := RichEdit.ScreenToClient(Pt);
  iCharIndex := SendMessage(RichEdit.Handle, Messages.EM_CHARFROMPOS, 0, Integer(@Pt));
  if iCharIndex >= 0 then begin
    if isValidChar(RichEdit.Text[iCharIndex]) then begin
      iLineIndex := RichEdit.Perform(EM_EXLINEFROMCHAR, 0, LPARAM(iCharIndex));
      iCharOffset := iCharIndex - RichEdit.Perform(Messages.EM_LINEINDEX, WPARAM(iLineIndex), 0);
      if length(RichEdit.Lines[iLineIndex]) > 0 then begin
        iWordStart := iCharOffset + 1;
        while iWordStart > 0 do begin
          if isValidChar(RichEdit.Lines[iLineIndex][iWordStart]) then
            iWordStart := iWordStart - 1
          else
            break;
        end;
        iWordEnd := iCharOffset + 1;
        while iWordEnd < length(RichEdit.Lines[iLineIndex]) do begin
          if isValidChar(RichEdit.Lines[iLineIndex][iWordEnd]) then
            iWordEnd := iWordEnd + 1
          else
            break;
        end;

        Result := Copy(RichEdit.Lines[iLineIndex],
                      iWordStart + 1, iWordEnd - iWordStart);
      end;

      if pos('https://', Result) <> 1 then Result := '';
    end;
  end;
end;

procedure UpdateWordUnderCursor(const RichEdit : TRichEdit);
var
  iWordStart, iWordEnd,
  iCharIndex, iLineIndex, iCharOffset: Integer;
  theWord : string;
  saveSelStart : integer;
begin
  if RichEdit.Cursor <> crNone then RichEdit.Cursor := crNone;

  iCharIndex := RichEdit.SelStart;

  if iCharIndex >= 0 then begin
    iLineIndex := RichEdit.Perform(EM_EXLINEFROMCHAR, 0, LPARAM(iCharIndex));
    iCharOffset := iCharIndex - RichEdit.Perform(Messages.EM_LINEINDEX, WPARAM(iLineIndex), 0);

    if length(RichEdit.Lines[iLineIndex]) > 0 then begin
      iWordStart := iCharOffset;
      iCharIndex := iCharIndex;
      while iWordStart > 0 do begin
        if isValidChar(RichEdit.Lines[iLineIndex][iWordStart]) then begin
          iWordStart := iWordStart - 1;
          iCharIndex := iCharIndex - 1;
        end else begin
          break;
        end;
      end;

      iWordEnd := iCharOffset + 1;
      while iWordEnd < length(RichEdit.Lines[iLineIndex]) do begin
        if isValidChar(RichEdit.Lines[iLineIndex][iWordEnd]) then
          iWordEnd := iWordEnd + 1
        else
          break;
      end;

      theWord := Copy(RichEdit.Lines[iLineIndex], iWordStart + 1, iWordEnd - iWordStart);
    end;

    SaveSelStart := RichEdit.SelStart;
    RichEdit.Perform(Messages.WM_USER + 63, WPARAM(TRUE), LPARAM(FALSE));
    RichEdit.SelStart := iCharIndex;
    RichEdit.SelLength := length(theWord);
    if pos('https://', theWord) = 1 then begin
      RichEdit.SelAttributes.Color := clBlue;
      RichEdit.SelAttributes.Style := [fsUnderline];
    end else begin
      RichEdit.SelAttributes.Color := clBlack;
      RichEdit.SelAttributes.Style := [];
    end;
    RichEdit.SelStart := SaveSelStart;
    RichEdit.Perform(Messages.WM_USER + 63, WPARAM(FALSE), LPARAM(FALSE));
  end;
end;

end.

Unit1 :

uses HighlightURL_unit

//

procedure TForm1.Button1Click(Sender: TObject);
begin
  HighlightURL(RichEdit1);
end;

procedure TForm1.RichEdit1Change(Sender: TObject);
var saveSelStart : Integer;
begin
  UpdateWordUnderCursor(RichEdit1);
end;


procedure TForm1.RichEdit1MouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
var s : string;
begin
  s := GetURLUnderCursor(RichEdit1);
  if s = '' then begin
    s := 'No URL under Cursor';
    RichEdit1.Cursor := crDefault;
  end else begin
    RichEdit1.Cursor := crHandPoint;
  end;
  StatusBar1.SimpleText := s;
end;