unit uRichEditExtended;

interface
uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, RichEdit, WinApi.ShellApi, Vcl.Controls, Vcl.ComCtrls,
  Generics.Collections;

type
  TZ_RichEditClickEvent = reference to procedure(const ALinkText: string);

  TZ_RichEditLink = class
    IsDefaultEvent: boolean;
    Text: string;
    OnLinkClickEvent: TZ_RichEditClickEvent;
  end;

  TZ_RichEditLinks = TList<TZ_RichEditLink>;

  TRichEditExtended = class
  protected
    class var FInstance: TRichEditExtended;
  private
    FPrevRichEditWndProc: TWndMethod;
    FRichEdit: TRichEdit;
    FRichEditLinks: TZ_RichEditLinks;
    procedure InsertLinkText(const LinkText: string; SelStart: integer = -1);
    procedure SetRichEditMasks;
    procedure RichEditWndProc(var Message: TMessage);
    procedure AfterConstruction; override;
    procedure BeforeDestruction; override;
  public
    class function This: TRichEditExtended;
    class procedure ApplyRichEdit(ARichEdit: TRichEdit);                              // -1 - вставка в конец текста, иначе в позицию указанную в SelStart без сдвига
    class function AddLinkText(AText: string; AOnLinkClickEvent: TZ_RichEditClickEvent; SelStart: integer = -1): integer;
    class function AddLinkTextWithDefaultEvent(AText: string; SelStart: integer = -1): integer;
    class procedure AddDefaultLinkTextEvent(AOnLinkClickEvent: TZ_RichEditClickEvent);
  end;

implementation

{ TRichEditExtended }
uses StrUtils;

class procedure TRichEditExtended.AddDefaultLinkTextEvent(AOnLinkClickEvent: TZ_RichEditClickEvent);
var
  REL: TZ_RichEditLink;
begin
  if (This.FRichEditLinks.Count > 0) and This.FRichEditLinks[0].IsDefaultEvent then
    This.FRichEditLinks[0].OnLinkClickEvent := AOnLinkClickEvent
  else
  begin
    REL := TZ_RichEditLink.Create;
    REL.IsDefaultEvent := true;
    REL.Text := '';
    REL.OnLinkClickEvent := AOnLinkClickEvent;
    This.FRichEditLinks.Insert(0, REL);
    REL := nil;
  end;
end;

class function TRichEditExtended.AddLinkText(AText: string; AOnLinkClickEvent: TZ_RichEditClickEvent; SelStart: integer = -1): integer;
var REL: TZ_RichEditLink;
begin
  REL := TZ_RichEditLink.Create;
  REL.IsDefaultEvent := false;
  REL.Text := AText;
  REL.OnLinkClickEvent := AOnLinkClickEvent;
  Result := This.FRichEditLinks.Add(REL);
  This.InsertLinkText(AText, SelStart);
  REL := nil;
end;

class function TRichEditExtended.AddLinkTextWithDefaultEvent(AText: string; SelStart: integer): integer;
begin
  This.AddLinkText(AText, nil, SelStart);
end;

procedure TRichEditExtended.AfterConstruction;
begin
  inherited;
  FRichEdit := nil;
  FRichEditLinks := TZ_RichEditLinks.Create;
end;

class procedure TRichEditExtended.ApplyRichEdit(ARichEdit: TRichEdit);
begin
  This.FRichEdit := ARichEdit;
  This.FPrevRichEditWndProc := This.FRichEdit.WindowProc;
  This.FRichEdit.WindowProc := This.RichEditWndProc;
  This.FRichEditLinks.Clear;
  This.SetRichEditMasks;
end;

procedure TRichEditExtended.BeforeDestruction;
begin
  if Assigned(FRichEdit) then
    FRichEdit.WindowProc := FPrevRichEditWndProc;
  FRichEdit := nil;
  FRichEditLinks.Clear;
  FRichEditLinks.Free;
  inherited;
end;

procedure TRichEditExtended.InsertLinkText(const LinkText: string; SelStart: integer = -1);
var
  Fmt: CHARFORMAT2;
begin
  if SelStart = -1 then
  begin
    SelStart := FRichEdit.Lines.Text.Length - 1;
    FRichEdit.Text := FRichEdit.Text + LinkText;
    dec(SelStart,2 * (FRichEdit.Lines.Text.CountChar(#$D) - 1));
  end
  else
  begin
    FRichEdit.SelStart := SelStart;
    FRichEdit.SelText := LinkText;
  end;
  FRichEdit.SelStart := SelStart;
  FRichEdit.SelLength := Length(LinkText);

  FillChar(Fmt, SizeOf(Fmt), 0);
  Fmt.cbSize := SizeOf(Fmt);
  Fmt.dwMask := CFM_LINK;
  Fmt.dwEffects := CFE_LINK;

  SendMessage(FRichEdit.Handle, EM_SETCHARFORMAT, SCF_SELECTION, LPARAM(@Fmt));

  FRichEdit.SelStart := SelStart + Length(LinkText);
  FRichEdit.SelLength := 0;
end;

procedure TRichEditExtended.RichEditWndProc(var Message: TMessage);
type
  PENLINK = ^ENLINK;
var
  tr: TEXTRANGE;
  str: string;
  p: PENLINK;
  i: integer;
begin
  FPrevRichEditWndProc(Message);

  case Message.Msg of
    CN_NOTIFY: begin
     if TWMNotify(Message).NMHdr.code = EN_LINK then
      begin
        P := PENLINK(Message.LParam);
        if p.msg = WM_LBUTTONDOWN then
        begin
          SetLength(str, p.chrg.cpMax - p.chrg.cpMin);
          tr.chrg := p.chrg;
          tr.lpstrText := PChar(str);
          SendMessage(FRichEdit.Handle, EM_GETTEXTRANGE, 0, LPARAM(@tr));

          for I := 0 to FRichEditLinks.Count - 1 do
            if str.ToUpper.Equals(FRichEditLinks[I].Text.ToUpper)  then
            begin
              if not Assigned(FRichEditLinks[I].OnLinkClickEvent) then
              begin
                if not FRichEditLinks[0].IsDefaultEvent then
                  raise Exception.Create('Необходимо назначить событие по умолчанию.')
                else
                  FRichEditLinks[0].OnLinkClickEvent(str)
              end
              else
                FRichEditLinks[I].OnLinkClickEvent(str);
              exit;
            end;
        end;
      end;
    end;

    CM_RECREATEWND: begin
      SetRichEditMasks;
    end;
  end;
end;

procedure TRichEditExtended.SetRichEditMasks;
var
  Mask: DWORD;
begin
  Mask := SendMessage(FRichEdit.Handle, EM_GETEVENTMASK, 0, 0);
  SendMessage(FRichEdit.Handle, EM_SETEVENTMASK, 0, Mask or ENM_LINK);
  SendMessage(FRichEdit.Handle, EM_AUTOURLDETECT, 1, 0);
end;

class function TRichEditExtended.This: TRichEditExtended;
begin
  if not Assigned(TRichEditExtended.FInstance) then
    TRichEditExtended.FInstance := TRichEditExtended.Create;
  Result := TRichEditExtended.FInstance;
end;

{ TRichEditExList }

initialization

finalization
  if Assigned(TRichEditExtended.FInstance) then
    TRichEditExtended.FInstance.Free;

end.