Delphi RichEdit - add multiple CFE_LINK effect via CHARFORMAT2 - delphi

Question

I have made a code, that inserts CFE_LINK into RichEdit text, but it works only for last inserted text. All previous insertions of Links are Undone.
I want to insert multiple Link-texts, but I cant figure out how to do that.
Here is a working code (with no errors):
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 - inserts to the end of text, otherwise into a position indicated by 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('No default event is set.')
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.
To run this code you should create a new Application, add TRichEdit on the Form and type the following in a FormCreate method:
TRichEditExtended.ApplyRichEdit(ed1);
TRichEditExtended.AddDefaultLinkTextEvent(procedure (const T: String)begin showmessage(T); end);
TRichEditExtended.AddLinkTextWithDefaultEvent('Link');
ed1.Text := ed1.Text + '1231232 ';
TRichEditExtended.AddLinkTextWithDefaultEvent('Link2');

Answer 1

InsertLinkText() is replacing FRichEdit.Text with a completely new string when inserting a link with SelStart=-1, thus losing all previous text and formatting.
Use FRichEdit.GetTextLen() instead of FRichEdit.Lines.Text.Length to get the length of the existing text. And regardless of the input SelStart, always use the FRichEdit.SelStart|SelLength|SelText properties to add the new link into FRichEdit, preserving all existing text and formatting.
procedure TRichEditExtended.InsertLinkText(const LinkText: string; SelStart: integer = -1);
var
Fmt: CHARFORMAT2;
//Range: CHARRANGE;
begin
if SelStart = -1 then SelStart := FRichEdit.GetTextLen;
FRichEdit.SelStart := SelStart;
FRichEdit.SelLength := 0;
{ or:
Range.cpMin := SelStart;
Range.cpMax := SelStart;
SendMessage(FRichEdit.Handle, EM_EXSETSEL, 0, LPARAM(#Range));
}
FRichEdit.SelText := LinkText;
FRichEdit.SelStart := SelStart;
FRichEdit.SelLength := Length(LinkText);
{ or:
Range.cpMin := SelStart;
Range.cpMax := SelStart + Length(LinkText);
SendMessage(FRichEdit.Handle, EM_EXSETSEL, 0, LPARAM(#Range));
}
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;
{ or:
Range.cpMin := SelStart + Length(LinkText);
Range.cpMax := Range.cpMax;
SendMessage(FRichEdit.Handle, EM_EXSETSEL, 0, LPARAM(#Range));
}
end;

Answer 2

As suggested by #KenWhite I will post my reseach upon the topic with edits about correct text highlighting due to issue of CRLF symbols in the text. As I found out line breaks are counted as one character for SelStart and GetTextLen, so you need to find the line where you are going to place a text and count all breaks before it and substract it from the desired SelStart position. For that purpose a function GetReilableSelStart is.
unit uRichEditExtended;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, RichEdit, WinApi.ShellApi, Vcl.Controls, Vcl.ComCtrls,
Generics.Collections, Vcl.Graphics;
type
TZ_RichEditClickEvent = reference to procedure(const ALinkText: string; LinkClickAccepted: boolean; var OutData: string);
TZ_RichEditLink = class
IsDefaultEvent: boolean;
Text: string;
OnLinkClickEvent: TZ_RichEditClickEvent;
end;
TZ_RichEditLinks = TList<TZ_RichEditLink>;
TZ_RichEditInsertOptions = set of (rioAppendBeforeCRLF);
TRichEditExtended = class
protected
class var FInstance: TRichEditExtended;
procedure SetRichEditMasks;
procedure RichEditWndProc(var Message: TMessage);
function GetReilableSelStart(SelStart: integer; InsertOptions: TZ_RichEditInsertOptions = [rioAppendBeforeCRLF]): integer;
private
FLastPressedLinkText: string;
FLinkClickAccepted: boolean;
FPrevRichEditWndProc: TWndMethod;
FRichEdit: TRichEdit;
FRichEditLinks: TZ_RichEditLinks;
function InsertText(const AText: string; const SelStart: integer = -1; InsertOptions: TZ_RichEditInsertOptions = [rioAppendBeforeCRLF]; Font: TFont = nil;
IsLink: boolean = false): integer;
procedure InsertLinkText(const LinkText: string; SelStart: integer = -1; InsertOptions: TZ_RichEditInsertOptions = [rioAppendBeforeCRLF]);
procedure AddText(const AText: string; AddCRLF: boolean; Font: TFont = nil);
procedure AddFmtText(const AText: string; FontSizeDelta: integer; FontStyle: TFontStyles; FontColor: TColor; AddCRLF: boolean);
procedure AfterConstruction; override;
procedure BeforeDestruction; override;
public
class function This: TRichEditExtended;
class procedure ApplyRichEdit(ARichEdit: TRichEdit);
class procedure AppendText(AText: string);
class procedure AppendTextLine(AText: string);
class procedure AppendFmtText(AText: string; FontSizeDelta: integer; FontStyle: TFontStyles; FontColor: TColor);
class procedure AppendFmtTextLine(AText: string; FontSizeDelta: integer; FontStyle: TFontStyles; FontColor: TColor);
class function AppendLinkText(AText: string; AOnLinkClickEvent: TZ_RichEditClickEvent; SelStart: integer = -1; InsertOptions: TZ_RichEditInsertOptions = [rioAppendBeforeCRLF]): integer;
class function AppendLinkTextWithDefaultEvent(AText: string; SelStart: integer = -1; InsertOptions: TZ_RichEditInsertOptions = [rioAppendBeforeCRLF]): integer;
class procedure AddDefaultLinkClickEvent(AOnLinkClickEvent: TZ_RichEditClickEvent);
class function LastLinkText: string;
class procedure PerformDefaultLinkClickEvent(const LinkText: string; CanOpen: boolean; var FullFilePath: string);
class procedure SetDefaultLinkClickReaction(ALinkClickAccepted: boolean);
end;
implementation
{ TRichEditExtended }
uses StrUtils, Math;
class procedure TRichEditExtended.AddDefaultLinkClickEvent(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;
procedure TRichEditExtended.AddFmtText(const AText: string; FontSizeDelta: integer; FontStyle: TFontStyles; FontColor: TColor; AddCRLF: boolean);
var Font: TFont;
begin
try
Font := TFont.Create;
Font.Size := This.FRichEdit.Font.Size + FontSizeDelta;
Font.Style := FontStyle;
Font.Color := FontColor;
Font.Name := This.FRichEdit.Font.Name;
This.AddText(AText, AddCRLF, Font);
finally
FreeAndNil(Font);
end;
end;
class function TRichEditExtended.AppendLinkText(AText: string; AOnLinkClickEvent: TZ_RichEditClickEvent; SelStart: integer = -1;
InsertOptions: TZ_RichEditInsertOptions = [rioAppendBeforeCRLF]): 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, InsertOptions);
REL := nil;
end;
class function TRichEditExtended.AppendLinkTextWithDefaultEvent(AText: string; SelStart: integer = -1; InsertOptions: TZ_RichEditInsertOptions = [rioAppendBeforeCRLF]): integer;
begin
This.AppendLinkText(AText, nil, SelStart, InsertOptions);
end;
procedure TRichEditExtended.AfterConstruction;
begin
inherited;
FRichEdit := nil;
FRichEditLinks := TZ_RichEditLinks.Create;
FLinkClickAccepted := false;
end;
procedure TRichEditExtended.AddText(const AText: string; AddCRLF: boolean; Font: TFont);
begin
if AddCRLF then
InsertText(Format('%s'#13#10,[AText]), -1, [rioAppendBeforeCRLF], Font)
else
InsertText(AText, -1, [rioAppendBeforeCRLF], Font);
end;
class procedure TRichEditExtended.AppendFmtText(AText: string; FontSizeDelta: integer; FontStyle: TFontStyles; FontColor: TColor);
begin
This.AddFmtText(AText, FontSizeDelta, FontStyle, FontColor, false);
end;
class procedure TRichEditExtended.AppendFmtTextLine(AText: string; FontSizeDelta: integer; FontStyle: TFontStyles; FontColor: TColor);
begin
This.AddFmtText(AText, FontSizeDelta, FontStyle, FontColor, true);
end;
class procedure TRichEditExtended.AppendText(AText: string);
begin
This.AddText(AText, false);
end;
class procedure TRichEditExtended.AppendTextLine(AText: string);
begin
This.AddText(AText, true);
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;
function TRichEditExtended.GetReilableSelStart(SelStart: integer; InsertOptions: TZ_RichEditInsertOptions = [rioAppendBeforeCRLF]): integer;
var
LineNo, LinesCount: integer;
begin
LinesCount := FRichEdit.Lines.Count;
if SelStart = -1 then
begin
Result := Max(FRichEdit.GetTextLen - Max((LinesCount - ord(not String(FRichEdit.Text).EndsWith(#$D#$A))),0), 0);
end
else
begin
LineNo := FRichEdit.Perform(EM_LINEFROMCHAR, SelStart, 0);
Result := Max(SelStart - (Max(LineNo - ord(rioAppendBeforeCRLF in InsertOptions) * ord(FRichEdit.Lines[LineNo].EndsWith(#$D#$A)),0)), 0);
end;
end;
procedure TRichEditExtended.InsertLinkText(const LinkText: string; SelStart: integer = -1; InsertOptions: TZ_RichEditInsertOptions = [rioAppendBeforeCRLF]);
var
Fmt: CHARFORMAT2;
begin
SelStart := InsertText(LinkText, SelStart, InsertOptions, nil, true);
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 := FRichEdit.GetTextLen;
FRichEdit.SelLength := 0;
end;
function TRichEditExtended.InsertText(const AText: string; const SelStart: integer = -1; InsertOptions: TZ_RichEditInsertOptions = [rioAppendBeforeCRLF];
Font: TFont = nil; IsLink: boolean = false): integer;
var
Fmt: CHARFORMAT2;
begin
Result := GetReilableSelStart(SelStart, InsertOptions);
FRichEdit.SelStart := Result;
FRichEdit.SelText := Format('%s%s',[AText, DupeString(#32,ord(IsLink))]);
FRichEdit.SelStart := Result;
FRichEdit.SelLength := Length(AText);
FRichEdit.SelAttributes.Color := FRichEdit.DefAttributes.Color;
FRichEdit.SelAttributes.Name := FRichEdit.DefAttributes.Name;
FRichEdit.SelAttributes.Size := FRichEdit.DefAttributes.Size;
FRichEdit.SelAttributes.Style := FRichEdit.DefAttributes.Style;
if Assigned(Font) then
begin
FRichEdit.SelAttributes.Color := Font.Color;
FRichEdit.SelAttributes.Name := Font.Name;
FRichEdit.SelAttributes.Size := Font.Size;
FRichEdit.SelAttributes.Style := Font.Style;
FRichEdit.SelStart := FRichEdit.GetTextLen;
FRichEdit.SelLength := 0;
end;
end;
class function TRichEditExtended.LastLinkText: string;
begin
Result := This.FLastPressedLinkText;
end;
class procedure TRichEditExtended.PerformDefaultLinkClickEvent(const LinkText: string; CanOpen: boolean; var FullFilePath: string);
begin
if (This.FRichEditLinks.Count = 0) or not This.FRichEditLinks[0].IsDefaultEvent then
raise Exception.Create('A default action should be set.');
This.FRichEditLinks[0].OnLinkClickEvent(LinkText, CanOpen, FullFilePath);
end;
procedure TRichEditExtended.RichEditWndProc(var Message: TMessage);
type
PENLINK = ^ENLINK;
var
tr: TEXTRANGE;
p: PENLINK;
i: integer;
OutDat: string;
function GetLinkText: string;
begin
SetLength(Result, p.chrg.cpMax - p.chrg.cpMin);
tr.chrg := p.chrg;
tr.lpstrText := PChar(Result);
SendMessage(FRichEdit.Handle, EM_GETTEXTRANGE, 0, LPARAM(#tr));
end;
begin
FPrevRichEditWndProc(Message);
case Message.Msg of
CN_NOTIFY: begin
if TWMNotify(Message).NMHdr.code = EN_LINK then
begin
P := PENLINK(Message.LParam);
case p.msg of
WM_LBUTTONDOWN:
begin
FLastPressedLinkText := GetLinkText;
for I := 0 to FRichEditLinks.Count - 1 do
if FLastPressedLinkText.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('A default action should be set.')
else
FRichEditLinks[0].OnLinkClickEvent(FLastPressedLinkText, FLinkClickAccepted, OutData)
end
else
FRichEditLinks[I].OnLinkClickEvent(FLastPressedLinkText, FLinkClickAccepted, OutData);
exit;
end;
end;
WM_RBUTTONDOWN:
begin
FLastPressedLinkText := GetLinkText;
if Assigned(FRichEdit.PopupMenu) then
begin
FRichEdit.PopupMenu.Popup(Mouse.CursorPos.X, Mouse.CursorPos.Y);
end;
end;
end;
end;
end;
CM_RECREATEWND: begin
SetRichEditMasks;
end;
end;
end;
class procedure TRichEditExtended.SetDefaultLinkClickReaction(ALinkClickAccepted: boolean);
begin
This.FLinkClickAccepted := ALinkClickAccepted;
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.
Any suggestions are appreciated.
How to use:
TRichEditExtended.ApplyRichEdit(edMessages);
TRichEditExtended.SetDefaultLinkClickReaction(true); //Link click accepted by default or not
TRichEditExtended.AddDefaultLinkClickEvent(
procedure (const LinkText: string; LinkClickAccepted: boolean; var OutData: string)
begin
if LinkClickAccepted then
DoSomething;
DoAnythingTo(OutData); // if you call somewhere after TRichEditExtended.PerformDefaultLinkClickEvent then you get the OutData there
end
);