pascal/lazarus-ccr
1
0
Fork 0
Code Issues Releases Activity

jvcllaz: Support all html entities, and improved painting of subscripts in HTML output (e.g. for TJvHTLabel)

Browse Source 
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@8274 8e941d3f-bd1b-0410-a28a-d453659cc2b4
This commit is contained in:
wp_xxyyzz
2022-05-06 22:34:52 +00:00
parent 3c11c8c7d0
commit 466086165b
3 changed files with 120 additions and 65 deletions
Download Patch File Download Diff File Expand all files Collapse all files

112
components/jvcllaz/run/JvCore/jvjvclutils.pas
View File

@ -871,7 +871,7 @@ function Scale96ToForm(ASize: Integer): Integer;
implementation
uses
sysutils, LCLIntf, GraphType, GraphUtil, FPImage, IntfGraphics, Math,
sysutils, LCLIntf, GraphType, GraphUtil, FPImage, IntfGraphics, Math, htmldefs, StrUtils,
{$IFDEF MSWINDOWS}
CommCtrl,
{$ENDIF}
@ -7125,6 +7125,7 @@ end;
const
cBR = '<BR>';
cBR2 = '<BR/>';
cBR3 = '<BR />';
cHR = '<HR>';
cTagBegin = '<';
cTagEnd = '>';
@ -7138,34 +7139,83 @@ const
cCOLOR = 'COLOR';
cBGCOLOR = 'BGCOLOR';
// moved from JvHTControls and renamed
function HTMLPrepareText(const Text: string): string;
type
THtmlCode = record
Html: string;
Text: UTF8String;
end;
const
Conversions: array [0..6] of THtmlCode = (
(Html: '&amp;'; Text: '&'),
(Html: '&quot;'; Text: '"'),
(Html: '&reg;'; Text: #$C2#$AE),
(Html: '&copy;'; Text: #$C2#$A9),
(Html: '&trade;'; Text: #$E2#$84#$A2),
(Html: '&euro;'; Text: #$E2#$82#$AC),
(Html: '&nbsp;'; Text: ' ')
);
// moved from JvHTControls and refactored to support all html entities
function HTMLPrepareText(const Text: String): String;
var
I: Integer;
i, j, len, p: Integer;
sEntity: String;
wEntity: WideString;
wChar: WideChar;
procedure AddCurrentChar;
begin
Result[j] := Text[i];
inc(j);
inc(i);
end;
begin
Result := Text;
for I := Low(Conversions) to High(Conversions) do
Result := StringReplace(Result, Conversions[I].Html, Utf8ToAnsi(Conversions[I].Text), [rfReplaceAll, rfIgnoreCase]);
Result := StringReplace(Result, #13, '', [rfReplaceAll]); // only <BR> can be new line
Result := StringReplace(Result, #10, '', [rfReplaceAll]); // only <BR> can be new line
Result := StringReplace(Result, cBR, sLineBreak, [rfReplaceAll, rfIgnoreCase]);
Result := StringReplace(Result, cBR2, sLineBreak, [rfReplaceAll, rfIgnoreCase]); // Fixes <BR/>, but not <BR />!
Result := StringReplace(Result, cHR, cHR + sLineBreak, [rfReplaceAll, rfIgnoreCase]); // fixed <HR><BR>
Result := '';
if Text = '' then
exit;
len := Length(Text);
SetLength(Result, len*4);
j := 1;
i := 1;
while i <= len do begin
if (Text[i] in [#10, #13]) then // only <br> is allowed for new line here
inc(i)
else
if Text[i] = '<' then
begin
if SameText(Copy(Text, i, Length(cBR)), cBR) then // Fixes <br>
begin
Move(LineEnding, Result[j], Length(LineEnding));
inc(j, Length(LineEnding));
inc(i, Length(cBR));
end else
if SameText(Copy(Text, i, Length(cBR2)), cBR2) then // Fixes <br/>
begin
Move(LineEnding, Result[j], Length(LineEnding));
inc(j, Length(LineEnding));
inc(i, Length(cBR2));
end else
if SameText(Copy(Text, i, Length(cBR3)), cBR3) then // Fixes <br />
begin
Move(LineEnding, Result[j], Length(LineEnding));
inc(j, Length(LineEnding));
inc(i, Length(cBR3));
end else
if SameText(Copy(Text, i, Length(cHR)), cHR) then // Fixes <hr>
begin
Move(cHR + LineEnding, Result[j], Length(cHR + LineEnding));
inc(j, Length(cHR + LineEnding));
inc(i, Length(cHR));
end else
AddCurrentChar;
end else
if Text[i] = '&' then
begin
p := PosEx(';', Text, i);
if p > 0 then
begin
sEntity := Copy(Text, i+1, p-i-1);
wEntity := WideString(sEntity);
if ResolveHTMLEntityReference(wEntity, wChar) then
begin
sEntity := UTF8Encode(wChar);
Move(sEntity[1], Result[j], Length(sEntity));
inc(j, Length(sEntity));
i := p+1;
end else
AddCurrentChar;
end else
AddCurrentChar;
end else
AddCurrentChar;
end;
SetLength(Result, j-1);
end;
function HTMLStringToColor(AText: String; ADefColor: TColor = clBlack): TColor;
@ -7351,8 +7401,12 @@ var
Width := Canvas.TextWidth(M);
Height := CanvasMaxTextHeight(Canvas);
if ScriptPosition = spSubscript then
R.Top := R.Top + lineHeight - Height - 1;
case ScriptPosition of
spSubscript:
R.Top := R.Top + lineHeight - abs(Canvas.Font.Height);
spSuperScript:
R.Top := R.Top + (Canvas.Font.Size - abs(Canvas.Font.Height));
end;
if IsLink and not MouseOnLink then
if (MouseY >= R.Top) and (MouseY <= R.Top + Height) and