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

jvcllaz: Improved HTML rendering routines (by Soner, https://forum.lazarus.freepascal.org/index.php/topic,41206.msg285740.html#msg285740).

Browse Source 
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@6406 8e941d3f-bd1b-0410-a28a-d453659cc2b4
This commit is contained in:
wp_xxyyzz
2018-05-12 16:17:53 +00:00
parent bc685aaeb8
commit efdc6a9ca2
1 changed files with 30 additions and 7 deletions
Download Patch File Download Diff File Expand all files Collapse all files

37
components/jvcllaz/run/JvCore/JvJVCLUtils.pas
View File

@ -754,6 +754,7 @@ function HTMLTextWidth(Canvas: TCanvas; Rect: TRect;
const State: TOwnerDrawState; const Text: string; SuperSubScriptRatio: Double; Scale: Integer = 100): Integer; const State: TOwnerDrawState; const Text: string; SuperSubScriptRatio: Double; Scale: Integer = 100): Integer;
function HTMLTextHeight(Canvas: TCanvas; const Text: string; SuperSubScriptRatio: Double; Scale: Integer = 100): Integer; function HTMLTextHeight(Canvas: TCanvas; const Text: string; SuperSubScriptRatio: Double; Scale: Integer = 100): Integer;
function HTMLPrepareText(const Text: string): string; function HTMLPrepareText(const Text: string): string;
function HTMLStringToColor(AText: String): TColor;
(************* (*************
@ -7072,6 +7073,26 @@ begin
Result := StringReplace(Result, cHR, cHR + sLineBreak, [rfReplaceAll, rfIgnoreCase]); // fixed <HR><BR> Result := StringReplace(Result, cHR, cHR + sLineBreak, [rfReplaceAll, rfIgnoreCase]); // fixed <HR><BR>
end; end;
function HTMLStringToColor(AText: String): TColor;
type
TRGBA = packed record
R, G, B, A: byte;
end;
var
i: Integer;
c: Int32;
begin
if AText[1] = '#' then AText[1] := '$';
if TryStrToInt(AText, c) then begin
TRgba(Result).R := TRgba(c).B;
TRgba(Result).G := TRgba(c).G;
TRgba(Result).B := TRgba(c).R;
TRgba(Result).A := 0;
end else begin
Result := StringToColor('cl'+AText);
end;
end;
function HTMLBeforeTag(var Str: string; DeleteToTag: Boolean = False): string; function HTMLBeforeTag(var Str: string; DeleteToTag: Boolean = False): string;
begin begin
if Pos(cTagBegin, Str) > 0 then if Pos(cTagBegin, Str) > 0 then
@ -7214,11 +7235,13 @@ var
Width, Height: Integer; Width, Height: Integer;
R: TRect; R: TRect;
OriginalFontSize: Integer; OriginalFontSize: Integer;
lineHeight: Integer;
begin begin
R := Rect; R := Rect;
Inc(R.Left, CurLeft); Inc(R.Left, CurLeft);
if Assigned(Canvas) then if Assigned(Canvas) then
begin begin
lineHeight := Canvas.TextHeight('Tg');
OriginalFontSize := Canvas.Font.Size; OriginalFontSize := Canvas.Font.Size;
try try
if ScriptPosition <> spNormal then if ScriptPosition <> spNormal then
@ -7228,7 +7251,7 @@ var
Height := CanvasMaxTextHeight(Canvas); Height := CanvasMaxTextHeight(Canvas);
if ScriptPosition = spSubscript then if ScriptPosition = spSubscript then
R.Top := R.Bottom - Height - 1; R.Top := R.Top + lineHeight - Height - 1;
if IsLink and not MouseOnLink then if IsLink and not MouseOnLink then
if (MouseY >= R.Top) and (MouseY <= R.Top + Height) and if (MouseY >= R.Top) and (MouseY <= R.Top + Height) and
@ -7276,6 +7299,10 @@ begin
if Canvas <> nil then if Canvas <> nil then
begin begin
if Lowercase(Canvas.Font.Name) = 'default' then
Canvas.Font.Name := Screen.SystemFont.Name;
if Canvas.Font.Size = 0 then
Canvas.Font.Size := Screen.SystemFont.Size;
OldFontStyles := Canvas.Font.Style; OldFontStyles := Canvas.Font.Style;
OldFontColor := Canvas.Font.Color; OldFontColor := Canvas.Font.Color;
OldBrushColor := Canvas.Brush.Color; OldBrushColor := Canvas.Brush.Color;
@ -7440,20 +7467,16 @@ begin
if Pos(cCOLOR, TagPrp) > 0 then if Pos(cCOLOR, TagPrp) > 0 then
begin begin
Prp := ExtractPropertyValue(TagPrp, cCOLOR); Prp := ExtractPropertyValue(TagPrp, cCOLOR);
if Prp[1] = '#' then Canvas.Font.Color := HTMLStringToColor(Prp);
Prp[1] := '$';
Canvas.Font.Color := StringToColor(Prp);
end; end;
if Pos(cBGCOLOR, TagPrp) > 0 then if Pos(cBGCOLOR, TagPrp) > 0 then
begin begin
Prp := ExtractPropertyValue(TagPrp, cBGCOLOR); Prp := ExtractPropertyValue(TagPrp, cBGCOLOR);
if Prp[1] = '#' then
Prp[1] := '$';
if UpperCase(Prp) = 'CLNONE' then if UpperCase(Prp) = 'CLNONE' then
Trans := True Trans := True
else else
begin begin
Canvas.Brush.Color := StringToColor(Prp); Canvas.Brush.Color := HTMLStringToColor(Prp);
Trans := False; Trans := False;
end; end;
end; end;